home *** CD-ROM | disk | FTP | other *** search
Text File | 2010-07-26 | 108.7 KB | 4,685 lines |
- # This file was generated by tool/generate-mouse-tiny.pl from Mouse 0.64.
- #
- # ANY CHANGES MADE HERE WILL BE LOST!
- use strict;
- use warnings;
- # if regular Mouse is loaded, bail out
- unless ($INC{'Mouse.pm'}) {
- # tell Perl we already have all of the Mouse files loaded:
- $INC{'Mouse.pm'} = __FILE__;
- $INC{'Mouse/Role.pm'} = __FILE__;
- $INC{'Mouse/PurePerl.pm'} = __FILE__;
- $INC{'Mouse/Object.pm'} = __FILE__;
- $INC{'Mouse/Util.pm'} = __FILE__;
- $INC{'Mouse/Exporter.pm'} = __FILE__;
- $INC{'Mouse/Meta/Method.pm'} = __FILE__;
- $INC{'Mouse/Meta/Module.pm'} = __FILE__;
- $INC{'Mouse/Meta/Role.pm'} = __FILE__;
- $INC{'Mouse/Meta/Class.pm'} = __FILE__;
- $INC{'Mouse/Meta/Attribute.pm'} = __FILE__;
- $INC{'Mouse/Meta/TypeConstraint.pm'} = __FILE__;
- $INC{'Mouse/Meta/Role/Method.pm'} = __FILE__;
- $INC{'Mouse/Meta/Role/Composite.pm'} = __FILE__;
- $INC{'Mouse/Meta/Method/Accessor.pm'} = __FILE__;
- $INC{'Mouse/Meta/Method/Destructor.pm'} = __FILE__;
- $INC{'Mouse/Meta/Method/Constructor.pm'} = __FILE__;
- $INC{'Mouse/Meta/Method/Delegation.pm'} = __FILE__;
- $INC{'Mouse/Util/TypeConstraints.pm'} = __FILE__;
- $INC{'Mouse/Util/MetaRole.pm'} = __FILE__;
- eval sprintf("#line %d %s\n", __LINE__, __FILE__) . <<'END_OF_TINY';
-
- # and now their contents
-
- BEGIN{ # lib/Mouse/PurePerl.pm
- package Mouse::PurePerl;
-
- require Mouse::Util;
-
- package Mouse::Util;
-
- use strict;
- use warnings;
-
- use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
-
- use B ();
-
-
- # taken from Class/MOP.pm
- sub is_valid_class_name {
- my $class = shift;
-
- return 0 if ref($class);
- return 0 unless defined($class);
-
- return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms;
-
- return 0;
- }
-
- sub is_class_loaded {
- my $class = shift;
-
- return 0 if ref($class) || !defined($class) || !length($class);
-
- # walk the symbol table tree to avoid autovififying
- # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::
-
- my $pack = \%::;
- foreach my $part (split('::', $class)) {
- $part .= '::';
- return 0 if !exists $pack->{$part};
-
- my $entry = \$pack->{$part};
- return 0 if ref($entry) ne 'GLOB';
- $pack = *{$entry}{HASH};
- }
-
- return 0 if !%{$pack};
-
- # check for $VERSION or @ISA
- return 1 if exists $pack->{VERSION}
- && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
- return 1 if exists $pack->{ISA}
- && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
-
- # check for any method
- foreach my $name( keys %{$pack} ) {
- my $entry = \$pack->{$name};
- return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
- }
-
- # fail
- return 0;
- }
-
-
- # taken from Sub::Identify
- sub get_code_info {
- my ($coderef) = @_;
- ref($coderef) or return;
-
- my $cv = B::svref_2object($coderef);
- $cv->isa('B::CV') or return;
-
- my $gv = $cv->GV;
- $gv->isa('B::GV') or return;
-
- return ($gv->STASH->NAME, $gv->NAME);
- }
-
- sub get_code_package{
- my($coderef) = @_;
-
- my $cv = B::svref_2object($coderef);
- $cv->isa('B::CV') or return '';
-
- my $gv = $cv->GV;
- $gv->isa('B::GV') or return '';
-
- return $gv->STASH->NAME;
- }
-
- sub get_code_ref{
- my($package, $name) = @_;
- no strict 'refs';
- no warnings 'once';
- use warnings FATAL => 'uninitialized';
- return *{$package . '::' . $name}{CODE};
- }
-
- sub generate_isa_predicate_for {
- my($for_class, $name) = @_;
-
- my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) };
-
- if(defined $name){
- Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
- return;
- }
-
- return $predicate;
- }
-
- sub generate_can_predicate_for {
- my($methods_ref, $name) = @_;
-
- my @methods = @{$methods_ref};
-
- my $predicate = sub{
- my($instance) = @_;
- if(Scalar::Util::blessed($instance)){
- foreach my $method(@methods){
- if(!$instance->can($method)){
- return 0;
- }
- }
- return 1;
- }
- return 0;
- };
-
- if(defined $name){
- Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
- return;
- }
-
- return $predicate;
- }
-
- package Mouse::Util::TypeConstraints;
-
- use Scalar::Util qw(blessed looks_like_number openhandle);
-
- sub Any { 1 }
- sub Item { 1 }
-
- sub Bool { $_[0] ? $_[0] eq '1' : 1 }
- sub Undef { !defined($_[0]) }
- sub Defined { defined($_[0]) }
- sub Value { defined($_[0]) && !ref($_[0]) }
- sub Num { looks_like_number($_[0]) }
- sub Int {
- my($value) = @_;
- looks_like_number($value) && $value =~ /\A [+-]? [0-9]+ \z/xms;
- }
- sub Str {
- my($value) = @_;
- return defined($value) && ref(\$value) eq 'SCALAR';
- }
-
- sub Ref { ref($_[0]) }
- sub ScalarRef {
- my($value) = @_;
- return ref($value) eq 'SCALAR'
- }
- sub ArrayRef { ref($_[0]) eq 'ARRAY' }
- sub HashRef { ref($_[0]) eq 'HASH' }
- sub CodeRef { ref($_[0]) eq 'CODE' }
- sub RegexpRef { ref($_[0]) eq 'Regexp' }
- sub GlobRef { ref($_[0]) eq 'GLOB' }
-
- sub FileHandle {
- return openhandle($_[0]) || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
- }
-
- sub Object { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
-
- sub ClassName { Mouse::Util::is_class_loaded($_[0]) }
- sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
-
- sub _parameterize_ArrayRef_for {
- my($type_parameter) = @_;
- my $check = $type_parameter->_compiled_type_constraint;
-
- return sub {
- foreach my $value (@{$_}) {
- return undef unless $check->($value);
- }
- return 1;
- }
- }
-
- sub _parameterize_HashRef_for {
- my($type_parameter) = @_;
- my $check = $type_parameter->_compiled_type_constraint;
-
- return sub {
- foreach my $value(values %{$_}){
- return undef unless $check->($value);
- }
- return 1;
- };
- }
-
- # 'Maybe' type accepts 'Any', so it requires parameters
- sub _parameterize_Maybe_for {
- my($type_parameter) = @_;
- my $check = $type_parameter->_compiled_type_constraint;
-
- return sub{
- return !defined($_) || $check->($_);
- };
- }
-
- package Mouse::Meta::Module;
-
- sub name { $_[0]->{package} }
-
- sub _method_map { $_[0]->{methods} }
- sub _attribute_map{ $_[0]->{attributes} }
-
- sub namespace{
- my $name = $_[0]->{package};
- no strict 'refs';
- return \%{ $name . '::' };
- }
-
- sub add_method {
- my($self, $name, $code) = @_;
-
- if(!defined $name){
- $self->throw_error('You must pass a defined name');
- }
- if(!defined $code){
- $self->throw_error('You must pass a defined code');
- }
-
- if(ref($code) ne 'CODE'){
- $code = \&{$code}; # coerce
- }
-
- $self->{methods}->{$name} = $code; # Moose stores meta object here.
-
- Mouse::Util::install_subroutines($self->name,
- $name => $code,
- );
- return;
- }
-
- package Mouse::Meta::Class;
-
- use Mouse::Meta::Method::Constructor;
- use Mouse::Meta::Method::Destructor;
-
- sub method_metaclass { $_[0]->{method_metaclass} || 'Mouse::Meta::Method' }
- sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' }
-
- sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' }
- sub destructor_class { $_[0]->{destructor_class} || 'Mouse::Meta::Method::Destructor' }
-
- sub is_anon_class{
- return exists $_[0]->{anon_serial_id};
- }
-
- sub roles { $_[0]->{roles} }
-
- sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } }
-
- sub get_all_attributes {
- my($self) = @_;
- my %attrs = map { %{ $self->initialize($_)->{attributes} } } reverse $self->linearized_isa;
- return values %attrs;
- }
-
- sub new_object {
- my $meta = shift;
- my %args = (@_ == 1 ? %{$_[0]} : @_);
-
- my $object = bless {}, $meta->name;
-
- $meta->_initialize_object($object, \%args);
- # BUILDALL
- if( $object->can('BUILD') ) {
- for my $class (reverse $meta->linearized_isa) {
- my $build = Mouse::Util::get_code_ref($class, 'BUILD')
- || next;
-
- $object->$build(\%args);
- }
- }
- return $object;
- }
-
- sub clone_object {
- my $class = shift;
- my $object = shift;
- my $args = $object->Mouse::Object::BUILDARGS(@_);
-
- (blessed($object) && $object->isa($class->name))
- || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
-
- my $cloned = bless { %$object }, ref $object;
- $class->_initialize_object($cloned, $args, 1);
-
- return $cloned;
- }
-
- sub _initialize_object{
- my($self, $object, $args, $is_cloning) = @_;
-
- my @triggers_queue;
-
- my $used = 0;
-
- foreach my $attribute ($self->get_all_attributes) {
- my $init_arg = $attribute->init_arg;
- my $slot = $attribute->name;
-
- if (defined($init_arg) && exists($args->{$init_arg})) {
- $object->{$slot} = $attribute->_coerce_and_verify($args->{$init_arg}, $object);
-
- weaken($object->{$slot})
- if ref($object->{$slot}) && $attribute->is_weak_ref;
-
- if ($attribute->has_trigger) {
- push @triggers_queue, [ $attribute->trigger, $object->{$slot} ];
- }
- $used++;
- }
- else { # no init arg
- if ($attribute->has_default || $attribute->has_builder) {
- if (!$attribute->is_lazy && !exists $object->{$slot}) {
- my $default = $attribute->default;
- my $builder = $attribute->builder;
- my $value = $builder ? $object->$builder()
- : ref($default) eq 'CODE' ? $object->$default()
- : $default;
-
- $object->{$slot} = $attribute->_coerce_and_verify($value, $object);
-
- weaken($object->{$slot})
- if ref($object->{$slot}) && $attribute->is_weak_ref;
- }
- }
- elsif(!$is_cloning && $attribute->is_required) {
- $self->throw_error("Attribute (".$attribute->name.") is required");
- }
- }
- }
-
- if($used < keys %{$args} && $self->strict_constructor) {
- $self->_report_unknown_args([ $self->get_all_attributes ], $args);
- }
-
- if(@triggers_queue){
- foreach my $trigger_and_value(@triggers_queue){
- my($trigger, $value) = @{$trigger_and_value};
- $trigger->($object, $value);
- }
- }
-
- if($self->is_anon_class){
- $object->{__METACLASS__} = $self;
- }
-
- return;
- }
-
- sub is_immutable { $_[0]->{is_immutable} }
-
- sub strict_constructor{
- my $self = shift;
- if(@_) {
- $self->{strict_constructor} = shift;
- }
-
- foreach my $class($self->linearized_isa) {
- my $meta = Mouse::Util::get_metaclass_by_name($class)
- or next;
-
- if(exists $meta->{strict_constructor}) {
- return $meta->{strict_constructor};
- }
- }
-
- return 0; # false
- }
-
- sub _report_unknown_args {
- my($metaclass, $attrs, $args) = @_;
-
- my @unknowns;
- my %init_args;
- foreach my $attr(@{$attrs}){
- my $init_arg = $attr->init_arg;
- if(defined $init_arg){
- $init_args{$init_arg}++;
- }
- }
-
- while(my $key = each %{$args}){
- if(!exists $init_args{$key}){
- push @unknowns, $key;
- }
- }
-
- $metaclass->throw_error( sprintf
- "Unknown attribute passed to the constructor of %s: %s",
- $metaclass->name, Mouse::Util::english_list(@unknowns),
- );
- }
-
- package Mouse::Meta::Role;
-
- sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' }
-
- sub is_anon_role{
- return exists $_[0]->{anon_serial_id};
- }
-
- sub get_roles { $_[0]->{roles} }
-
- sub add_before_method_modifier {
- my ($self, $method_name, $method) = @_;
-
- push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method;
- return;
- }
- sub add_around_method_modifier {
- my ($self, $method_name, $method) = @_;
-
- push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method;
- return;
- }
- sub add_after_method_modifier {
- my ($self, $method_name, $method) = @_;
-
- push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method;
- return;
- }
-
- sub get_before_method_modifiers {
- my ($self, $method_name) = @_;
- return @{ $self->{before_method_modifiers}{$method_name} ||= [] }
- }
- sub get_around_method_modifiers {
- my ($self, $method_name) = @_;
- return @{ $self->{around_method_modifiers}{$method_name} ||= [] }
- }
- sub get_after_method_modifiers {
- my ($self, $method_name) = @_;
- return @{ $self->{after_method_modifiers}{$method_name} ||= [] }
- }
-
- package Mouse::Meta::Attribute;
-
- require Mouse::Meta::Method::Accessor;
-
- sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' }
-
- # readers
-
- sub name { $_[0]->{name} }
- sub associated_class { $_[0]->{associated_class} }
-
- sub accessor { $_[0]->{accessor} }
- sub reader { $_[0]->{reader} }
- sub writer { $_[0]->{writer} }
- sub predicate { $_[0]->{predicate} }
- sub clearer { $_[0]->{clearer} }
- sub handles { $_[0]->{handles} }
-
- sub _is_metadata { $_[0]->{is} }
- sub is_required { $_[0]->{required} }
- sub default { $_[0]->{default} }
- sub is_lazy { $_[0]->{lazy} }
- sub is_lazy_build { $_[0]->{lazy_build} }
- sub is_weak_ref { $_[0]->{weak_ref} }
- sub init_arg { $_[0]->{init_arg} }
- sub type_constraint { $_[0]->{type_constraint} }
-
- sub trigger { $_[0]->{trigger} }
- sub builder { $_[0]->{builder} }
- sub should_auto_deref { $_[0]->{auto_deref} }
- sub should_coerce { $_[0]->{coerce} }
-
- sub documentation { $_[0]->{documentation} }
- sub insertion_order { $_[0]->{insertion_order} }
-
- # predicates
-
- sub has_accessor { exists $_[0]->{accessor} }
- sub has_reader { exists $_[0]->{reader} }
- sub has_writer { exists $_[0]->{writer} }
- sub has_predicate { exists $_[0]->{predicate} }
- sub has_clearer { exists $_[0]->{clearer} }
- sub has_handles { exists $_[0]->{handles} }
-
- sub has_default { exists $_[0]->{default} }
- sub has_type_constraint { exists $_[0]->{type_constraint} }
- sub has_trigger { exists $_[0]->{trigger} }
- sub has_builder { exists $_[0]->{builder} }
-
- sub has_documentation { exists $_[0]->{documentation} }
-
- sub _process_options{
- my($class, $name, $args) = @_;
-
- # taken from Class::MOP::Attribute::new
-
- defined($name)
- or $class->throw_error('You must provide a name for the attribute');
-
- if(!exists $args->{init_arg}){
- $args->{init_arg} = $name;
- }
-
- # 'required' requires eigher 'init_arg', 'builder', or 'default'
- my $can_be_required = defined( $args->{init_arg} );
-
- if(exists $args->{builder}){
- # XXX:
- # Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility
- # This feature will be changed in a future. (gfx)
- $class->throw_error('builder must be a defined scalar value which is a method name')
- #if ref $args->{builder} || !defined $args->{builder};
- if !defined $args->{builder};
-
- $can_be_required++;
- }
- elsif(exists $args->{default}){
- if(ref $args->{default} && ref($args->{default}) ne 'CODE'){
- $class->throw_error("References are not allowed as default values, you must "
- . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])");
- }
- $can_be_required++;
- }
-
- if( $args->{required} && !$can_be_required ) {
- $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg");
- }
-
- # taken from Mouse::Meta::Attribute->new and ->_process_args
-
- if(exists $args->{is}){
- my $is = $args->{is};
-
- if($is eq 'ro'){
- $args->{reader} ||= $name;
- }
- elsif($is eq 'rw'){
- if(exists $args->{writer}){
- $args->{reader} ||= $name;
- }
- else{
- $args->{accessor} ||= $name;
- }
- }
- elsif($is eq 'bare'){
- # do nothing, but don't complain (later) about missing methods
- }
- else{
- $is = 'undef' if !defined $is;
- $class->throw_error("I do not understand this option (is => $is) on attribute ($name)");
- }
- }
-
- my $tc;
- if(exists $args->{isa}){
- $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
- }
-
- if(exists $args->{does}){
- if(defined $tc){ # both isa and does supplied
- my $does_ok = do{
- local $@;
- eval{ "$tc"->does($args) };
- };
- if(!$does_ok){
- $class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)");
- }
- }
- else {
- $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
- }
- }
-
- if($args->{coerce}){
- defined($tc)
- || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)");
-
- $args->{weak_ref}
- && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)");
- }
-
- if ($args->{lazy_build}) {
- exists($args->{default})
- && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)");
-
- $args->{lazy} = 1;
- $args->{builder} ||= "_build_${name}";
- if ($name =~ /^_/) {
- $args->{clearer} ||= "_clear${name}";
- $args->{predicate} ||= "_has${name}";
- }
- else {
- $args->{clearer} ||= "clear_${name}";
- $args->{predicate} ||= "has_${name}";
- }
- }
-
- if ($args->{auto_deref}) {
- defined($tc)
- || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)");
-
- ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') )
- || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)");
- }
-
- if (exists $args->{trigger}) {
- ('CODE' eq ref $args->{trigger})
- || $class->throw_error("Trigger must be a CODE ref on attribute ($name)");
- }
-
- if ($args->{lazy}) {
- (exists $args->{default} || defined $args->{builder})
- || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it");
- }
-
- return;
- }
-
-
- package Mouse::Meta::TypeConstraint;
-
- sub name { $_[0]->{name} }
- sub parent { $_[0]->{parent} }
- sub message { $_[0]->{message} }
-
- sub type_parameter { $_[0]->{type_parameter} }
- sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
- sub _compiled_type_coercion { $_[0]->{_compiled_type_coercion} }
-
- sub __is_parameterized { exists $_[0]->{type_parameter} }
- sub has_coercion { exists $_[0]->{_compiled_type_coercion} }
-
-
- sub compile_type_constraint{
- my($self) = @_;
-
- # add parents first
- my @checks;
- for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){
- if($parent->{hand_optimized_type_constraint}){
- unshift @checks, $parent->{hand_optimized_type_constraint};
- last; # a hand optimized constraint must include all the parents
- }
- elsif($parent->{constraint}){
- unshift @checks, $parent->{constraint};
- }
- }
-
- # then add child
- if($self->{constraint}){
- push @checks, $self->{constraint};
- }
-
- if($self->{type_constraints}){ # Union
- my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} };
- push @checks, sub{
- foreach my $c(@types){
- return 1 if $c->($_[0]);
- }
- return 0;
- };
- }
-
- if(@checks == 0){
- $self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any;
- }
- else{
- $self->{compiled_type_constraint} = sub{
- my(@args) = @_;
- local $_ = $args[0];
- foreach my $c(@checks){
- return undef if !$c->(@args);
- }
- return 1;
- };
- }
- return;
- }
-
- sub check {
- my $self = shift;
- return $self->_compiled_type_constraint->(@_);
- }
-
-
- package Mouse::Object;
-
- sub BUILDARGS {
- my $class = shift;
-
- if (scalar @_ == 1) {
- (ref($_[0]) eq 'HASH')
- || $class->meta->throw_error("Single parameters to new() must be a HASH ref");
-
- return {%{$_[0]}};
- }
- else {
- return {@_};
- }
- }
-
- sub new {
- my $class = shift;
-
- $class->meta->throw_error('Cannot call new() on an instance') if ref $class;
-
- my $args = $class->BUILDARGS(@_);
-
- my $meta = Mouse::Meta::Class->initialize($class);
- return $meta->new_object($args);
- }
-
- sub DESTROY {
- my $self = shift;
-
- return unless $self->can('DEMOLISH'); # short circuit
-
- local $?;
-
- my $e = do{
- local $@;
- eval{
- # DEMOLISHALL
-
- # We cannot count on being able to retrieve a previously made
- # metaclass, _or_ being able to make a new one during global
- # destruction. However, we should still be able to use mro at
- # that time (at least tests suggest so ;)
-
- foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) {
- my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH')
- || next;
-
- $self->$demolish($Mouse::Util::in_global_destruction);
- }
- };
- $@;
- };
-
- no warnings 'misc';
- die $e if $e; # rethrow
- }
-
- sub BUILDALL {
- my $self = shift;
-
- # short circuit
- return unless $self->can('BUILD');
-
- for my $class (reverse $self->meta->linearized_isa) {
- my $build = Mouse::Util::get_code_ref($class, 'BUILD')
- || next;
-
- $self->$build(@_);
- }
- return;
- }
-
- sub DEMOLISHALL;
- *DEMOLISHALL = \&DESTROY;
-
- }
- BEGIN{ # lib/Mouse/Exporter.pm
- package Mouse::Exporter;
- use strict;
- use warnings;
-
- use Carp qw(confess);
-
- my %SPEC;
-
- my $strict_bits;
- BEGIN{ $strict_bits = strict::bits(qw(subs refs vars)); }
-
- my $warnings_extra_bits;
- BEGIN{ $warnings_extra_bits = warnings::bits(FATAL => 'recursion') }
-
- # it must be "require", because Mouse::Util depends on Mouse::Exporter,
- # which depends on Mouse::Util::import()
- require Mouse::Util;
-
- sub import{
- # strict->import;
- $^H |= $strict_bits;
- # warnings->import('all', FATAL => 'recursion');
- ${^WARNING_BITS} |= $warnings::Bits{all};
- ${^WARNING_BITS} |= $warnings_extra_bits;
- return;
- }
-
-
- sub setup_import_methods{
- my($class, %args) = @_;
-
- my $exporting_package = $args{exporting_package} ||= caller();
-
- my($import, $unimport) = $class->build_import_methods(%args);
-
- Mouse::Util::install_subroutines($exporting_package,
- import => $import,
- unimport => $unimport,
-
- export_to_level => sub {
- my($package, $level, undef, @args) = @_; # the third argument is redundant
- $package->import({ into_level => $level + 1 }, @args);
- },
- export => sub {
- my($package, $into, @args) = @_;
- $package->import({ into => $into }, @args);
- },
- );
- return;
- }
-
- sub build_import_methods{
- my($self, %args) = @_;
-
- my $exporting_package = $args{exporting_package} ||= caller();
-
- $SPEC{$exporting_package} = \%args;
-
- # canonicalize args
- my @export_from;
- if($args{also}){
- my %seen;
- my @stack = ($exporting_package);
-
- while(my $current = shift @stack){
- push @export_from, $current;
-
- my $also = $SPEC{$current}{also} or next;
- push @stack, grep{ !$seen{$_}++ } ref($also) ? @{ $also } : $also;
- }
- }
- else{
- @export_from = ($exporting_package);
- }
-
- my %exports;
- my @removables;
- my @all;
-
- my @init_meta_methods;
-
- foreach my $package(@export_from){
- my $spec = $SPEC{$package} or next;
-
- if(my $as_is = $spec->{as_is}){
- foreach my $thingy (@{$as_is}){
- my($code_package, $code_name, $code);
-
- if(ref($thingy)){
- $code = $thingy;
- ($code_package, $code_name) = Mouse::Util::get_code_info($code);
- }
- else{
- $code_package = $package;
- $code_name = $thingy;
- no strict 'refs';
- $code = \&{ $code_package . '::' . $code_name };
- }
-
- push @all, $code_name;
- $exports{$code_name} = $code;
- if($code_package eq $package){
- push @removables, $code_name;
- }
- }
- }
-
- if(my $init_meta = $package->can('init_meta')){
- if(!grep{ $_ == $init_meta } @init_meta_methods){
- push @init_meta_methods, $init_meta;
- }
- }
- }
- $args{EXPORTS} = \%exports;
- $args{REMOVABLES} = \@removables;
-
- $args{groups}{all} ||= \@all;
-
- if(my $default_list = $args{groups}{default}){
- my %default;
- foreach my $keyword(@{$default_list}){
- $default{$keyword} = $exports{$keyword}
- || confess(qq{The $exporting_package package does not export "$keyword"});
- }
- $args{DEFAULT} = \%default;
- }
- else{
- $args{groups}{default} ||= \@all;
- $args{DEFAULT} = $args{EXPORTS};
- }
-
- if(@init_meta_methods){
- $args{INIT_META} = \@init_meta_methods;
- }
-
- return (\&do_import, \&do_unimport);
- }
-
-
- # the entity of general import()
- sub do_import {
- my($package, @args) = @_;
-
- my $spec = $SPEC{$package}
- || confess("The package $package package does not use Mouse::Exporter");
-
- my $into = _get_caller_package(ref($args[0]) ? shift @args : undef);
-
- my @exports;
- my @traits;
-
- while(@args){
- my $arg = shift @args;
- if($arg =~ s/^-//){
- if($arg eq 'traits'){
- push @traits, ref($args[0]) ? @{shift(@args)} : shift(@args);
- }
- else {
- Mouse::Util::not_supported("-$arg");
- }
- }
- elsif($arg =~ s/^://){
- my $group = $spec->{groups}{$arg}
- || confess(qq{The $package package does not export the group "$arg"});
- push @exports, @{$group};
- }
- else{
- push @exports, $arg;
- }
- }
-
- $^H |= $strict_bits; # strict->import;
- # warnings->import('all', FATAL => 'recursion');
- ${^WARNING_BITS} |= $warnings::Bits{all};
- ${^WARNING_BITS} |= $warnings_extra_bits;
-
- if($spec->{INIT_META}){
- my $meta;
- foreach my $init_meta(@{$spec->{INIT_META}}){
- $meta = $package->$init_meta(for_class => $into);
- }
-
- if(@traits){
- my $type = (split /::/, ref $meta)[-1]; # e.g. "Class" for "My::Meta::Class"
- @traits =
- map{
- ref($_) ? $_
- : Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1)
- } @traits;
-
- require Mouse::Util::MetaRole;
- Mouse::Util::MetaRole::apply_metaroles(
- for => $into,
- Mouse::Util::is_a_metarole($into->meta)
- ? (role_metaroles => { role => \@traits })
- : (class_metaroles => { class => \@traits }),
- );
- }
- }
- elsif(@traits){
- Carp::confess("Cannot provide traits when $package does not have an init_meta() method");
- }
-
- if(@exports){
- my @export_table;
- foreach my $keyword(@exports){
- push @export_table,
- $keyword => ($spec->{EXPORTS}{$keyword}
- || confess(qq{The $package package does not export "$keyword"})
- );
- }
- Mouse::Util::install_subroutines($into, @export_table);
- }
- else{
- Mouse::Util::install_subroutines($into, %{$spec->{DEFAULT}});
- }
- return;
- }
-
- # the entity of general unimport()
- sub do_unimport {
- my($package, $arg) = @_;
-
- my $spec = $SPEC{$package}
- || confess("The package $package does not use Mouse::Exporter");
-
- my $from = _get_caller_package($arg);
-
- my $stash = do{
- no strict 'refs';
- \%{$from . '::'}
- };
-
- for my $keyword (@{ $spec->{REMOVABLES} }) {
- next if !exists $stash->{$keyword};
- my $gv = \$stash->{$keyword};
- if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us
- delete $stash->{$keyword};
- }
- }
- return;
- }
-
- sub _get_caller_package {
- my($arg) = @_;
-
- # We need one extra level because it's called by import so there's a layer
- # of indirection
- if(ref $arg){
- return defined($arg->{into}) ? $arg->{into}
- : defined($arg->{into_level}) ? scalar caller(1 + $arg->{into_level})
- : scalar caller(1);
- }
- else{
- return scalar caller(1);
- }
- }
-
- #sub _spec{ %SPEC }
-
- }
- BEGIN{ # lib/Mouse/Util.pm
- package Mouse::Util;
- use Mouse::Exporter; # enables strict and warnings
-
- # must be here because it will be refered by other modules loaded
- sub get_linear_isa($;$); ## no critic
-
- # must be here because it will called in Mouse::Exporter
- sub install_subroutines {
- my $into = shift;
-
- while(my($name, $code) = splice @_, 0, 2){
- no strict 'refs';
- no warnings 'once', 'redefine';
- use warnings FATAL => 'uninitialized';
- *{$into . '::' . $name} = \&{$code};
- }
- return;
- }
-
- BEGIN{
- # This is used in Mouse::PurePerl
- Mouse::Exporter->setup_import_methods(
- as_is => [qw(
- find_meta
- does_role
- resolve_metaclass_alias
- apply_all_roles
- english_list
-
- load_class
- is_class_loaded
-
- get_linear_isa
- get_code_info
-
- get_code_package
- get_code_ref
-
- not_supported
-
- does meta dump
- )],
- groups => {
- default => [], # export no functions by default
-
- # The ':meta' group is 'use metaclass' for Mouse
- meta => [qw(does meta dump)],
- },
- );
-
-
- # Because Mouse::Util is loaded first in all the Mouse sub-modules,
- # XS loader is placed here, not in Mouse.pm.
-
- our $VERSION = '0.64';
-
- my $xs = !(exists $INC{'Mouse/PurePerl.pm'} || $ENV{MOUSE_PUREPERL});
-
- if($xs){
- # XXX: XSLoader tries to get the object path from caller's file name
- # $hack_mouse_file fools its mechanism
-
- (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm
- $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
- local $^W = 0; # work around 'redefine' warning to &install_subroutines
- require XSLoader;
- XSLoader::load('Mouse', $VERSION);
- Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta');
- Mouse::Util->import({ into => 'Mouse::Meta::Method::Destructor::XS' }, ':meta');
- Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS' }, ':meta');
- return 1;
- } || 0;
- #warn $@ if $@;
- }
-
- if(!$xs){
- require 'Mouse/PurePerl.pm'; # we don't want to create its namespace
- }
-
- *MOUSE_XS = sub(){ $xs };
- }
-
- use Carp ();
- use Scalar::Util ();
-
- # aliases as public APIs
- # it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
- require Mouse::Meta::Module; # for the entities of metaclass cache utilities
-
- # aliases
- {
- *class_of = \&Mouse::Meta::Module::_class_of;
- *get_metaclass_by_name = \&Mouse::Meta::Module::_get_metaclass_by_name;
- *get_all_metaclass_instances = \&Mouse::Meta::Module::_get_all_metaclass_instances;
- *get_all_metaclass_names = \&Mouse::Meta::Module::_get_all_metaclass_names;
-
- *Mouse::load_class = \&load_class;
- *Mouse::is_class_loaded = \&is_class_loaded;
-
- # is-a predicates
- #generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
- #generate_isa_predicate_for('Mouse::Meta::Class' => 'is_a_metaclass');
- #generate_isa_predicate_for('Mouse::Meta::Role' => 'is_a_metarole');
-
- # duck type predicates
- generate_can_predicate_for(['_compiled_type_constraint'] => 'is_a_type_constraint');
- generate_can_predicate_for(['create_anon_class'] => 'is_a_metaclass');
- generate_can_predicate_for(['create_anon_role'] => 'is_a_metarole');
- }
-
- our $in_global_destruction = 0;
- END{ $in_global_destruction = 1 }
-
- # Moose::Util compatible utilities
-
- sub find_meta{
- return class_of( $_[0] );
- }
-
- sub does_role{
- my ($class_or_obj, $role_name) = @_;
-
- my $meta = class_of($class_or_obj);
-
- (defined $role_name)
- || ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
-
- return defined($meta) && $meta->does_role($role_name);
- }
-
- BEGIN {
- my $get_linear_isa;
- if ($] >= 5.009_005) {
- require mro;
- $get_linear_isa = \&mro::get_linear_isa;
- } else {
- # this code is based on MRO::Compat::__get_linear_isa
- my $_get_linear_isa_dfs; # this recurses so it isn't pretty
- $_get_linear_isa_dfs = sub {
- my($classname) = @_;
-
- my @lin = ($classname);
- my %stored;
-
- no strict 'refs';
- foreach my $parent (@{"$classname\::ISA"}) {
- foreach my $p(@{ $_get_linear_isa_dfs->($parent) }) {
- next if exists $stored{$p};
- push(@lin, $p);
- $stored{$p} = 1;
- }
- }
- return \@lin;
- };
-
- {
- package # hide from PAUSE
- Class::C3;
- our %MRO; # work around 'once' warnings
- }
-
- # MRO::Compat::__get_linear_isa has no prototype, so
- # we define a prototyped version for compatibility with core's
- # See also MRO::Compat::__get_linear_isa.
- $get_linear_isa = sub ($;$){
- my($classname, $type) = @_;
-
- if(!defined $type){
- $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
- }
- if($type eq 'c3'){
- require Class::C3;
- return [Class::C3::calculateMRO($classname)];
- }
- else{
- return $_get_linear_isa_dfs->($classname);
- }
- };
- }
-
- *get_linear_isa = $get_linear_isa;
- }
-
-
- # taken from Mouse::Util (0.90)
- {
- my %cache;
-
- sub resolve_metaclass_alias {
- my ( $type, $metaclass_name, %options ) = @_;
-
- my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
-
- return $cache{$cache_key}{$metaclass_name} ||= do{
-
- my $possible_full_name = join '::',
- 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
- ;
-
- my $loaded_class = load_first_existing_class(
- $possible_full_name,
- $metaclass_name
- );
-
- $loaded_class->can('register_implementation')
- ? $loaded_class->register_implementation
- : $loaded_class;
- };
- }
- }
-
- # Utilities from Class::MOP
-
- sub get_code_info;
- sub get_code_package;
-
- sub is_valid_class_name;
-
- # taken from Class/MOP.pm
- sub load_first_existing_class {
- my @classes = @_
- or return;
-
- my %exceptions;
- for my $class (@classes) {
- my $e = _try_load_one_class($class);
-
- if ($e) {
- $exceptions{$class} = $e;
- }
- else {
- return $class;
- }
- }
-
- # not found
- Carp::confess join(
- "\n",
- map {
- sprintf( "Could not load class (%s) because : %s",
- $_, $exceptions{$_} )
- } @classes
- );
- }
-
- # taken from Class/MOP.pm
- sub _try_load_one_class {
- my $class = shift;
-
- unless ( is_valid_class_name($class) ) {
- my $display = defined($class) ? $class : 'undef';
- Carp::confess "Invalid class name ($display)";
- }
-
- return '' if is_class_loaded($class);
-
- $class =~ s{::}{/}g;
- $class .= '.pm';
-
- return do {
- local $@;
- eval { require $class };
- $@;
- };
- }
-
-
- sub load_class {
- my $class = shift;
- my $e = _try_load_one_class($class);
- Carp::confess "Could not load class ($class) because : $e" if $e;
-
- return $class;
- }
-
- sub is_class_loaded;
-
- sub apply_all_roles {
- my $consumer = Scalar::Util::blessed($_[0])
- ? shift # instance
- : Mouse::Meta::Class->initialize(shift); # class or role name
-
- my @roles;
-
- # Basis of Data::OptList
- my $max = scalar(@_);
- for (my $i = 0; $i < $max ; $i++) {
- if ($i + 1 < $max && ref($_[$i + 1])) {
- push @roles, [ $_[$i] => $_[++$i] ];
- } else {
- push @roles, [ $_[$i] => undef ];
- }
- my $role_name = $roles[-1][0];
- load_class($role_name);
-
- is_a_metarole( get_metaclass_by_name($role_name) )
- || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
- }
-
- if ( scalar @roles == 1 ) {
- my ( $role_name, $params ) = @{ $roles[0] };
- get_metaclass_by_name($role_name)->apply( $consumer, defined $params ? $params : () );
- }
- else {
- Mouse::Meta::Role->combine(@roles)->apply($consumer);
- }
- return;
- }
-
- # taken from Moose::Util 0.90
- sub english_list {
- return $_[0] if @_ == 1;
-
- my @items = sort @_;
-
- return "$items[0] and $items[1]" if @items == 2;
-
- my $tail = pop @items;
-
- return join q{, }, @items, "and $tail";
- }
-
- sub quoted_english_list {
- return english_list(map { qq{'$_'} } @_);
- }
-
- # common utilities
-
- sub not_supported{
- my($feature) = @_;
-
- $feature ||= ( caller(1) )[3]; # subroutine name
-
- local $Carp::CarpLevel = $Carp::CarpLevel + 1;
- Carp::confess("Mouse does not currently support $feature");
- }
-
- # general meta() method
- sub meta :method{
- return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
- }
-
- # general dump() method
- sub dump :method {
- my($self, $maxdepth) = @_;
-
- require 'Data/Dumper.pm'; # we don't want to create its namespace
- my $dd = Data::Dumper->new([$self]);
- $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
- $dd->Indent(1);
- return $dd->Dump();
- }
-
- # general does() method
- sub does :method {
- goto &does_role;
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/TypeConstraint.pm
- package Mouse::Meta::TypeConstraint;
- use Mouse::Util qw(:meta); # enables strict and warnings
- use Scalar::Util ();
-
- use overload
- 'bool' => sub (){ 1 }, # always true
- '""' => sub { $_[0]->name }, # stringify to tc name
- '0+' => sub { Scalar::Util::refaddr($_[0]) },
- '|' => sub { # or-combination
- require Mouse::Util::TypeConstraints;
- return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
- "$_[0] | $_[1]",
- );
- },
-
- fallback => 1;
-
- sub new {
- my $class = shift;
- my %args = @_ == 1 ? %{$_[0]} : @_;
-
- $args{name} = '__ANON__' if !defined $args{name};
-
- my $check = delete $args{optimized};
-
- if($check){
- $args{hand_optimized_type_constraint} = $check;
- $args{compiled_type_constraint} = $check;
- }
-
- $check = $args{constraint};
-
- if(defined($check) && ref($check) ne 'CODE'){
- $class->throw_error("Constraint for $args{name} is not a CODE reference");
- }
-
- my $self = bless \%args, $class;
- $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
-
- $self->_compile_union_type_coercion() if $self->{type_constraints};
- return $self;
- }
-
- sub create_child_type{
- my $self = shift;
- return ref($self)->new(
- # a child inherits its parent's attributes
- %{$self},
-
- # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
- compiled_type_constraint => undef,
- hand_optimized_type_constraint => undef,
-
- # and is given child-specific args, of course.
- @_,
-
- # and its parent
- parent => $self,
- );
- }
-
- sub name;
- sub parent;
- sub message;
- sub has_coercion;
-
- sub check;
-
- sub type_parameter;
- sub __is_parameterized;
-
- sub _compiled_type_constraint;
- sub _compiled_type_coercion;
-
- sub compile_type_constraint;
-
-
- sub _add_type_coercions{
- my $self = shift;
-
- my $coercions = ($self->{coercion_map} ||= []);
- my %has = map{ $_->[0] => undef } @{$coercions};
-
- for(my $i = 0; $i < @_; $i++){
- my $from = $_[ $i];
- my $action = $_[++$i];
-
- if(exists $has{$from}){
- $self->throw_error("A coercion action already exists for '$from'");
- }
-
- my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
- or $self->throw_error("Could not find the type constraint ($from) to coerce from");
-
- push @{$coercions}, [ $type => $action ];
- }
-
- # compile
- if(exists $self->{type_constraints}){ # union type
- $self->throw_error("Cannot add additional type coercions to Union types");
- }
- else{
- $self->_compile_type_coercion();
- }
- return;
- }
-
- sub _compile_type_coercion {
- my($self) = @_;
-
- my @coercions = @{$self->{coercion_map}};
-
- $self->{_compiled_type_coercion} = sub {
- my($thing) = @_;
- foreach my $pair (@coercions) {
- #my ($constraint, $converter) = @$pair;
- if ($pair->[0]->check($thing)) {
- local $_ = $thing;
- return $pair->[1]->($thing);
- }
- }
- return $thing;
- };
- return;
- }
-
- sub _compile_union_type_coercion {
- my($self) = @_;
-
- my @coercions;
- foreach my $type(@{$self->{type_constraints}}){
- if($type->has_coercion){
- push @coercions, $type;
- }
- }
- if(@coercions){
- $self->{_compiled_type_coercion} = sub {
- my($thing) = @_;
- foreach my $type(@coercions){
- my $value = $type->coerce($thing);
- return $value if $self->check($value);
- }
- return $thing;
- };
- }
- return;
- }
-
- sub coerce {
- my $self = shift;
-
- my $coercion = $self->_compiled_type_coercion;
- if(!$coercion){
- $self->throw_error("Cannot coerce without a type coercion");
- }
-
- return $_[0] if $self->check(@_);
-
- return $coercion->(@_);
- }
-
- sub get_message {
- my ($self, $value) = @_;
- if ( my $msg = $self->message ) {
- local $_ = $value;
- return $msg->($value);
- }
- else {
- $value = ( defined $value ? overload::StrVal($value) : 'undef' );
- return "Validation failed for '$self' with value $value";
- }
- }
-
- sub is_a_type_of{
- my($self, $other) = @_;
-
- # ->is_a_type_of('__ANON__') is always false
- return 0 if !ref($other) && $other eq '__ANON__';
-
- (my $other_name = $other) =~ s/\s+//g;
-
- return 1 if $self->name eq $other_name;
-
- if(exists $self->{type_constraints}){ # union
- foreach my $type(@{$self->{type_constraints}}){
- return 1 if $type->name eq $other_name;
- }
- }
-
- for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
- return 1 if $parent->name eq $other_name;
- }
-
- return 0;
- }
-
- # See also Moose::Meta::TypeConstraint::Parameterizable
- sub parameterize{
- my($self, $param, $name) = @_;
-
- if(!ref $param){
- require Mouse::Util::TypeConstraints;
- $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
- }
-
- $name ||= sprintf '%s[%s]', $self->name, $param->name;
-
- my $generator = $self->{constraint_generator}
- || $self->throw_error("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
-
- return Mouse::Meta::TypeConstraint->new(
- name => $name,
- parent => $self,
- type_parameter => $param,
- constraint => $generator->($param), # must be 'constraint', not 'optimized'
- );
- }
-
- sub assert_valid {
- my ($self, $value) = @_;
-
- if(!$self->check($value)){
- $self->throw_error($self->get_message($value));
- }
- return 1;
- }
-
- sub throw_error {
- require Mouse::Meta::Module;
- goto &Mouse::Meta::Module::throw_error;
- }
-
- }
- BEGIN{ # lib/Mouse/Util/TypeConstraints.pm
- package Mouse::Util::TypeConstraints;
- use Mouse::Util qw(does_role not_supported); # enables strict and warnings
-
- use Carp ();
- use Scalar::Util ();
-
- use Mouse::Meta::TypeConstraint;
- use Mouse::Exporter;
-
- Mouse::Exporter->setup_import_methods(
- as_is => [qw(
- as where message optimize_as
- from via
-
- type subtype class_type role_type duck_type
- enum
- coerce
-
- find_type_constraint
- register_type_constraint
- )],
- );
-
- our @CARP_NOT = qw(Mouse::Meta::Attribute);
-
- my %TYPE;
-
- # The root type
- $TYPE{Any} = Mouse::Meta::TypeConstraint->new(
- name => 'Any',
- );
-
- my @builtins = (
- # $name => $parent, $code,
-
- # the base type
- Item => 'Any', undef,
-
- # the maybe[] type
- Maybe => 'Item', undef,
-
- # value types
- Undef => 'Item', \&Undef,
- Defined => 'Item', \&Defined,
- Bool => 'Item', \&Bool,
- Value => 'Defined', \&Value,
- Str => 'Value', \&Str,
- Num => 'Str', \&Num,
- Int => 'Num', \&Int,
-
- # ref types
- Ref => 'Defined', \&Ref,
- ScalarRef => 'Ref', \&ScalarRef,
- ArrayRef => 'Ref', \&ArrayRef,
- HashRef => 'Ref', \&HashRef,
- CodeRef => 'Ref', \&CodeRef,
- RegexpRef => 'Ref', \&RegexpRef,
- GlobRef => 'Ref', \&GlobRef,
-
- # object types
- FileHandle => 'GlobRef', \&FileHandle,
- Object => 'Ref', \&Object,
-
- # special string types
- ClassName => 'Str', \&ClassName,
- RoleName => 'ClassName', \&RoleName,
- );
-
-
- while (my ($name, $parent, $code) = splice @builtins, 0, 3) {
- $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
- name => $name,
- parent => $TYPE{$parent},
- optimized => $code,
- );
- }
-
- # make it parametarizable
-
- $TYPE{Maybe} {constraint_generator} = \&_parameterize_Maybe_for;
- $TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for;
- $TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for;
-
- # sugars
-
- sub as ($) { (as => $_[0]) } ## no critic
- sub where (&) { (where => $_[0]) } ## no critic
- sub message (&) { (message => $_[0]) } ## no critic
- sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic
-
- sub from { @_ }
- sub via (&) { $_[0] } ## no critic
-
- # type utilities
-
- sub optimized_constraints { # DEPRECATED
- Carp::cluck('optimized_constraints() has been deprecated');
- return \%TYPE;
- }
-
- undef @builtins; # free the allocated memory
- @builtins = keys %TYPE; # reuse it
- sub list_all_builtin_type_constraints { @builtins }
-
- sub list_all_type_constraints { keys %TYPE }
-
- sub _create_type{
- my $mode = shift;
-
- my $name;
- my %args;
-
- if(@_ == 1 && ref $_[0]){ # @_ : { name => $name, where => ... }
- %args = %{$_[0]};
- }
- elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
- $name = $_[0];
- %args = %{$_[1]};
- }
- elsif(@_ % 2){ # @_ : $name => ( where => ... )
- ($name, %args) = @_;
- }
- else{ # @_ : (name => $name, where => ...)
- %args = @_;
- }
-
- if(!defined $name){
- $name = $args{name};
- }
-
- $args{name} = $name;
- my $parent;
- if($mode eq 'subtype'){
- $parent = delete $args{as};
- if(!$parent){
- $parent = delete $args{name};
- $name = undef;
- }
- }
-
- if(defined $name){
- # set 'package_defined_in' only if it is not a core package
- my $this = $args{package_defined_in};
- if(!$this){
- $this = caller(1);
- if($this !~ /\A Mouse \b/xms){
- $args{package_defined_in} = $this;
- }
- }
-
- if($TYPE{$name}){
- my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__;
- ($this eq $that) or Carp::croak(
- "The type constraint '$name' has already been created in $that and cannot be created again in $this"
- );
- }
- }
- else{
- $args{name} = '__ANON__';
- }
-
- $args{constraint} = delete $args{where} if exists $args{where};
- $args{optimized} = delete $args{optimized_as} if exists $args{optimized_as};
-
- my $constraint;
- if($mode eq 'subtype'){
- $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args);
- }
- else{
- $constraint = Mouse::Meta::TypeConstraint->new(%args);
- }
-
- if(defined $name){
- return $TYPE{$name} = $constraint;
- }
- else{
- return $constraint;
- }
- }
-
- sub type {
- return _create_type('type', @_);
- }
-
- sub subtype {
- return _create_type('subtype', @_);
- }
-
- sub coerce {
- my $type_name = shift;
-
- my $type = find_type_constraint($type_name)
- or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it.");
-
- $type->_add_type_coercions(@_);
- return;
- }
-
- sub class_type {
- my($name, $options) = @_;
- my $class = $options->{class} || $name;
-
- # ClassType
- return _create_type 'subtype', $name => (
- as => 'Object',
- optimized_as => Mouse::Util::generate_isa_predicate_for($class),
- );
- }
-
- sub role_type {
- my($name, $options) = @_;
- my $role = $options->{role} || $name;
-
- # RoleType
- return _create_type 'subtype', $name => (
- as => 'Object',
- optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) },
- );
- }
-
- sub duck_type {
- my($name, @methods);
-
- if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
- $name = shift;
- }
-
- @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
-
- # DuckType
- return _create_type 'subtype', $name => (
- as => 'Object',
- optimized_as => Mouse::Util::generate_can_predicate_for(\@methods),
- );
- }
-
- sub enum {
- my($name, %valid);
-
- if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
- $name = shift;
- }
-
- %valid = map{ $_ => undef } (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_);
-
- # EnumType
- return _create_type 'subtype', $name => (
- as => 'Str',
- optimized_as => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
- );
- }
-
- sub _find_or_create_regular_type{
- my($spec, $create) = @_;
-
- return $TYPE{$spec} if exists $TYPE{$spec};
-
- my $meta = Mouse::Util::get_metaclass_by_name($spec);
-
- if(!defined $meta){
- return $create ? class_type($spec) : undef;
- }
-
- if(Mouse::Util::is_a_metarole($meta)){
- return role_type($spec);
- }
- else{
- return class_type($spec);
- }
- }
-
- sub _find_or_create_parameterized_type{
- my($base, $param) = @_;
-
- my $name = sprintf '%s[%s]', $base->name, $param->name;
-
- $TYPE{$name} ||= $base->parameterize($param, $name);
- }
-
- sub _find_or_create_union_type{
- return if grep{ not defined } @_;
- my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
-
- my $name = join '|', @types;
-
- # UnionType
- $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new(
- name => $name,
- type_constraints => \@types,
- );
- }
-
- # The type parser
-
- # param : '[' type ']' | NOTHING
- sub _parse_param {
- my($c) = @_;
-
- if($c->{spec} =~ s/^\[//){
- my $type = _parse_type($c, 1);
-
- if($c->{spec} =~ s/^\]//){
- return $type;
- }
- Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'");
- }
-
- return undef;
- }
-
- # name : [\w.:]+
- sub _parse_name {
- my($c, $create) = @_;
-
- if($c->{spec} =~ s/\A ([\w.:]+) //xms){
- return _find_or_create_regular_type($1, $create);
- }
- Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'");
- }
-
- # single_type : name param
- sub _parse_single_type {
- my($c, $create) = @_;
-
- my $type = _parse_name($c, $create);
- my $param = _parse_param($c);
-
- if(defined $type){
- if(defined $param){
- return _find_or_create_parameterized_type($type, $param);
- }
- else {
- return $type;
- }
- }
- elsif(defined $param){
- Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'");
- }
- else{
- return undef;
- }
- }
-
- # type : single_type ('|' single_type)*
- sub _parse_type {
- my($c, $create) = @_;
-
- my $type = _parse_single_type($c, $create);
- if($c->{spec}){ # can be an union type
- my @types;
- while($c->{spec} =~ s/^\|//){
- push @types, _parse_single_type($c, $create);
- }
- if(@types){
- return _find_or_create_union_type($type, @types);
- }
- }
- return $type;
- }
-
-
- sub find_type_constraint {
- my($spec) = @_;
- return $spec if Mouse::Util::is_a_type_constraint($spec);
- return undef if !defined $spec;
-
- $spec =~ s/\s+//g;
- return $TYPE{$spec};
- }
-
- sub register_type_constraint {
- my($constraint) = @_;
- Carp::croak("No type supplied / type is not a valid type constraint")
- unless Mouse::Util::is_a_type_constraint($constraint);
- my $name = $constraint->name;
- Carp::croak("can't register an unnamed type constraint")
- unless defined $name;
- return $TYPE{$name} = $constraint;
- }
-
- sub find_or_parse_type_constraint {
- my($spec) = @_;
- return $spec if Mouse::Util::is_a_type_constraint($spec);
- return undef if !defined $spec;
-
- $spec =~ s/\s+//g;
- return $TYPE{$spec} || do{
- my $context = {
- spec => $spec,
- orig => $spec,
- };
- my $type = _parse_type($context);
-
- if($context->{spec}){
- Carp::croak("Syntax error: extra elements '$context->{spec}' in '$context->{orig}'");
- }
- $type;
- };
- }
-
- sub find_or_create_does_type_constraint{
- # XXX: Moose does not register a new role_type, but Mouse does.
- return find_or_parse_type_constraint(@_) || role_type(@_);
- }
-
- sub find_or_create_isa_type_constraint {
- # XXX: Moose does not register a new class_type, but Mouse does.
- return find_or_parse_type_constraint(@_) || class_type(@_);
- }
-
- }
- BEGIN{ # lib/Mouse.pm
- package Mouse;
- use 5.006_002;
-
- use Mouse::Exporter; # enables strict and warnings
-
- our $VERSION = '0.64';
-
- use Carp qw(confess);
- use Scalar::Util qw(blessed);
-
- use Mouse::Util ();
-
- use Mouse::Meta::Module;
- use Mouse::Meta::Class;
- use Mouse::Meta::Role;
- use Mouse::Meta::Attribute;
- use Mouse::Object;
- use Mouse::Util::TypeConstraints ();
-
- Mouse::Exporter->setup_import_methods(
- as_is => [qw(
- extends with
- has
- before after around
- override super
- augment inner
- ),
- \&Scalar::Util::blessed,
- \&Carp::confess,
- ],
- );
-
-
- sub extends {
- Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_);
- return;
- }
-
- sub with {
- Mouse::Util::apply_all_roles(scalar(caller), @_);
- return;
- }
-
- sub has {
- my $meta = Mouse::Meta::Class->initialize(scalar caller);
- my $name = shift;
-
- $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
- if @_ % 2; # odd number of arguments
-
- if(ref $name){ # has [qw(foo bar)] => (...)
- for (@{$name}){
- $meta->add_attribute($_ => @_);
- }
- }
- else{ # has foo => (...)
- $meta->add_attribute($name => @_);
- }
- return;
- }
-
- sub before {
- my $meta = Mouse::Meta::Class->initialize(scalar caller);
- my $code = pop;
- for my $name($meta->_collect_methods(@_)) {
- $meta->add_before_method_modifier($name => $code);
- }
- return;
- }
-
- sub after {
- my $meta = Mouse::Meta::Class->initialize(scalar caller);
- my $code = pop;
- for my $name($meta->_collect_methods(@_)) {
- $meta->add_after_method_modifier($name => $code);
- }
- return;
- }
-
- sub around {
- my $meta = Mouse::Meta::Class->initialize(scalar caller);
- my $code = pop;
- for my $name($meta->_collect_methods(@_)) {
- $meta->add_around_method_modifier($name => $code);
- }
- return;
- }
-
- our $SUPER_PACKAGE;
- our $SUPER_BODY;
- our @SUPER_ARGS;
-
- sub super {
- # This check avoids a recursion loop - see
- # t/100_bugs/020_super_recursion.t
- return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
- return if !defined $SUPER_BODY;
- $SUPER_BODY->(@SUPER_ARGS);
- }
-
- sub override {
- # my($name, $method) = @_;
- Mouse::Meta::Class->initialize(scalar caller)->add_override_method_modifier(@_);
- }
-
- our %INNER_BODY;
- our %INNER_ARGS;
-
- sub inner {
- my $pkg = caller();
- if ( my $body = $INNER_BODY{$pkg} ) {
- my $args = $INNER_ARGS{$pkg};
- local $INNER_ARGS{$pkg};
- local $INNER_BODY{$pkg};
- return $body->(@{$args});
- }
- else {
- return;
- }
- }
-
- sub augment {
- #my($name, $method) = @_;
- Mouse::Meta::Class->initialize(scalar caller)->add_augment_method_modifier(@_);
- return;
- }
-
- sub init_meta {
- shift;
- my %args = @_;
-
- my $class = $args{for_class}
- or confess("Cannot call init_meta without specifying a for_class");
-
- my $base_class = $args{base_class} || 'Mouse::Object';
- my $metaclass = $args{metaclass} || 'Mouse::Meta::Class';
-
- my $meta = $metaclass->initialize($class);
-
- $meta->add_method(meta => sub{
- return $metaclass->initialize(ref($_[0]) || $_[0]);
- });
-
- $meta->superclasses($base_class)
- unless $meta->superclasses;
-
- # make a class type for each Mouse class
- Mouse::Util::TypeConstraints::class_type($class)
- unless Mouse::Util::TypeConstraints::find_type_constraint($class);
-
- return $meta;
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Attribute.pm
- package Mouse::Meta::Attribute;
- use Mouse::Util qw(:meta); # enables strict and warnings
-
- use Carp ();
-
- use Mouse::Meta::TypeConstraint;
-
- my %valid_options = map { $_ => undef } (
- 'accessor',
- 'auto_deref',
- 'builder',
- 'clearer',
- 'coerce',
- 'default',
- 'documentation',
- 'does',
- 'handles',
- 'init_arg',
- 'insertion_order',
- 'is',
- 'isa',
- 'lazy',
- 'lazy_build',
- 'name',
- 'predicate',
- 'reader',
- 'required',
- 'traits',
- 'trigger',
- 'type_constraint',
- 'weak_ref',
- 'writer',
-
- # internally used
- 'associated_class',
- 'associated_methods',
-
- # Moose defines, but Mouse doesn't
- #'definition_context',
- #'initializer',
-
- # special case for AttributeHelpers
- 'provides',
- 'curries',
- );
-
- our @CARP_NOT = qw(Mouse::Meta::Class);
-
- sub new {
- my $class = shift;
- my $name = shift;
-
- my $args = $class->Mouse::Object::BUILDARGS(@_);
-
- $class->_process_options($name, $args);
-
- $args->{name} = $name;
-
- # check options
- # (1) known by core
- my @bad = grep{ !exists $valid_options{$_} } keys %{$args};
-
- # (2) known by subclasses
- if(@bad && $class ne __PACKAGE__){
- my %valid_attrs = (
- map { $_ => undef }
- grep { defined }
- map { $_->init_arg() }
- $class->meta->get_all_attributes()
- );
- @bad = grep{ !exists $valid_attrs{$_} } @bad;
- }
-
- # (3) bad options found
- if(@bad){
- Carp::carp(
- "Found unknown argument(s) passed to '$name' attribute constructor in '$class': "
- . Mouse::Util::english_list(@bad));
- }
-
- my $self = bless $args, $class;
-
- # extra attributes
- if($class ne __PACKAGE__){
- $class->meta->_initialize_object($self, $args);
- }
-
- return $self;
- }
-
- sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
- sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
-
- sub _create_args { # DEPRECATED
- $_[0]->{_create_args} = $_[1] if @_ > 1;
- $_[0]->{_create_args}
- }
-
- sub interpolate_class{
- my($class, $args) = @_;
-
- if(my $metaclass = delete $args->{metaclass}){
- $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass );
- }
-
- my @traits;
- if(my $traits_ref = delete $args->{traits}){
-
- for (my $i = 0; $i < @{$traits_ref}; $i++) {
- my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1);
-
- next if $class->does($trait);
-
- push @traits, $trait;
-
- # are there options?
- push @traits, $traits_ref->[++$i]
- if ref($traits_ref->[$i+1]);
- }
-
- if (@traits) {
- $class = Mouse::Meta::Class->create_anon_class(
- superclasses => [ $class ],
- roles => \@traits,
- cache => 1,
- )->name;
- }
- }
-
- return( $class, @traits );
- }
-
- sub _coerce_and_verify {
- #my($self, $value, $instance) = @_;
- my($self, $value) = @_;
-
- my $type_constraint = $self->{type_constraint};
- return $value if !defined $type_constraint;
-
- if ($self->should_coerce && $type_constraint->has_coercion) {
- $value = $type_constraint->coerce($value);
- }
-
- $self->verify_against_type_constraint($value);
-
- return $value;
- }
-
- sub verify_against_type_constraint {
- my ($self, $value) = @_;
-
- my $type_constraint = $self->{type_constraint};
- return 1 if !$type_constraint;
- return 1 if $type_constraint->check($value);
-
- $self->_throw_type_constraint_error($value, $type_constraint);
- }
-
- sub _throw_type_constraint_error {
- my($self, $value, $type) = @_;
-
- $self->throw_error(
- sprintf q{Attribute (%s) does not pass the type constraint because: %s},
- $self->name,
- $type->get_message($value),
- );
- }
-
- sub illegal_options_for_inheritance {
- return qw(is reader writer accessor clearer predicate);
- }
-
- sub clone_and_inherit_options{
- my $self = shift;
- my $args = $self->Mouse::Object::BUILDARGS(@_);
-
- foreach my $illegal($self->illegal_options_for_inheritance) {
- if(exists $args->{$illegal} and exists $self->{$illegal}) {
- $self->throw_error("Illegal inherited option: $illegal");
- }
- }
-
- foreach my $name(keys %{$self}){
- if(!exists $args->{$name}){
- $args->{$name} = $self->{$name}; # inherit from self
- }
- }
-
- my($attribute_class, @traits) = ref($self)->interpolate_class($args);
- $args->{traits} = \@traits if @traits;
-
- # remove temporary caches
- foreach my $attr(keys %{$args}){
- if($attr =~ /\A _/xms){
- delete $args->{$attr};
- }
- }
-
- # remove default if lazy_build => 1
- if($args->{lazy_build}) {
- delete $args->{default};
- }
-
- return $attribute_class->new($self->name, $args);
- }
-
- sub get_read_method {
- return $_[0]->reader || $_[0]->accessor
- }
- sub get_write_method {
- return $_[0]->writer || $_[0]->accessor
- }
-
- sub _get_accessor_method_ref {
- my($self, $type, $generator) = @_;
-
- my $metaclass = $self->associated_class
- || $self->throw_error('No asocciated class for ' . $self->name);
-
- my $accessor = $self->$type();
- if($accessor){
- return $metaclass->get_method_body($accessor);
- }
- else{
- return $self->accessor_metaclass->$generator($self, $metaclass);
- }
- }
-
- sub get_read_method_ref{
- my($self) = @_;
- return $self->{_read_method_ref} ||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader');
- }
-
- sub get_write_method_ref{
- my($self) = @_;
- return $self->{_write_method_ref} ||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer');
- }
-
- sub set_value {
- my($self, $object, $value) = @_;
- return $self->get_write_method_ref()->($object, $value);
- }
-
- sub get_value {
- my($self, $object) = @_;
- return $self->get_read_method_ref()->($object);
- }
-
- sub has_value {
- my($self, $object) = @_;
- my $accessor_ref = $self->{_predicate_ref}
- ||= $self->_get_accessor_method_ref('predicate', '_generate_predicate');
-
- return $accessor_ref->($object);
- }
-
- sub clear_value {
- my($self, $object) = @_;
- my $accessor_ref = $self->{_crealer_ref}
- ||= $self->_get_accessor_method_ref('clearer', '_generate_clearer');
-
- return $accessor_ref->($object);
- }
-
-
- sub associate_method{
- #my($attribute, $method_name) = @_;
- my($attribute) = @_;
- $attribute->{associated_methods}++;
- return;
- }
-
- sub install_accessors{
- my($attribute) = @_;
-
- my $metaclass = $attribute->associated_class;
- my $accessor_class = $attribute->accessor_metaclass;
-
- foreach my $type(qw(accessor reader writer predicate clearer)){
- if(exists $attribute->{$type}){
- my $generator = '_generate_' . $type;
- my $code = $accessor_class->$generator($attribute, $metaclass);
- $metaclass->add_method($attribute->{$type} => $code);
- $attribute->associate_method($attribute->{$type});
- }
- }
-
- # install delegation
- if(exists $attribute->{handles}){
- my %handles = $attribute->_canonicalize_handles($attribute->{handles});
-
- while(my($handle, $method_to_call) = each %handles){
- if($metaclass->has_method($handle)) {
- $attribute->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation");
- }
-
- $metaclass->add_method($handle =>
- $attribute->_make_delegation_method(
- $handle, $method_to_call));
-
- $attribute->associate_method($handle);
- }
- }
-
- return;
- }
-
- sub delegation_metaclass() { ## no critic
- 'Mouse::Meta::Method::Delegation'
- }
-
- sub _canonicalize_handles {
- my($self, $handles) = @_;
-
- if (ref($handles) eq 'HASH') {
- return %$handles;
- }
- elsif (ref($handles) eq 'ARRAY') {
- return map { $_ => $_ } @$handles;
- }
- elsif ( ref($handles) eq 'CODE' ) {
- my $class_or_role = ( $self->{isa} || $self->{does} )
- || $self->throw_error( "Cannot find delegate metaclass for attribute " . $self->name );
- return $handles->( $self, Mouse::Meta::Class->initialize("$class_or_role"));
- }
- elsif (ref($handles) eq 'Regexp') {
- my $class_or_role = ($self->{isa} || $self->{does})
- || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)");
-
- my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify
- return map { $_ => $_ }
- grep { !Mouse::Object->can($_) && $_ =~ $handles }
- Mouse::Util::is_a_metarole($meta)
- ? $meta->get_method_list
- : $meta->get_all_method_names;
- }
- else {
- $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
- }
- }
-
- sub _make_delegation_method {
- my($self, $handle, $method_to_call) = @_;
- return Mouse::Util::load_class($self->delegation_metaclass)
- ->_generate_delegation($self, $handle, $method_to_call);
- }
-
- sub throw_error{
- my $self = shift;
-
- my $metaclass = (ref $self && $self->associated_class) || 'Mouse::Meta::Class';
- $metaclass->throw_error(@_, depth => 1);
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Class.pm
- package Mouse::Meta::Class;
- use Mouse::Util qw/:meta get_linear_isa not_supported/; # enables strict and warnings
-
- use Scalar::Util qw/blessed weaken/;
-
- use Mouse::Meta::Module;
- our @ISA = qw(Mouse::Meta::Module);
-
- our @CARP_NOT = qw(Mouse); # trust Mouse
-
- sub attribute_metaclass;
- sub method_metaclass;
-
- sub constructor_class;
- sub destructor_class;
-
-
- sub _construct_meta {
- my($class, %args) = @_;
-
- $args{attributes} = {};
- $args{methods} = {};
- $args{roles} = [];
-
- $args{superclasses} = do {
- no strict 'refs';
- \@{ $args{package} . '::ISA' };
- };
-
- my $self = bless \%args, ref($class) || $class;
- if(ref($self) ne __PACKAGE__){
- $self->meta->_initialize_object($self, \%args);
- }
- return $self;
- }
-
- sub create_anon_class{
- my $self = shift;
- return $self->create(undef, @_);
- }
-
- sub is_anon_class;
-
- sub roles;
-
- sub calculate_all_roles {
- my $self = shift;
- my %seen;
- return grep { !$seen{ $_->name }++ }
- map { $_->calculate_all_roles } @{ $self->roles };
- }
-
- sub superclasses {
- my $self = shift;
-
- if (@_) {
- foreach my $super(@_){
- Mouse::Util::load_class($super);
- my $meta = Mouse::Util::get_metaclass_by_name($super);
-
- next if not defined $meta;
-
- if(Mouse::Util::is_a_metarole($meta)){
- $self->throw_error("You cannot inherit from a Mouse Role ($super)");
- }
-
- next if $self->isa(ref $meta); # _superclass_meta_is_compatible
-
- $self->_reconcile_with_superclass_meta($meta);
- }
- @{ $self->{superclasses} } = @_;
- }
-
- return @{ $self->{superclasses} };
- }
- my @MetaClassTypes = (
- 'attribute', # Mouse::Meta::Attribute
- 'method', # Mouse::Meta::Method
- 'constructor', # Mouse::Meta::Method::Constructor
- 'destructor', # Mouse::Meta::Method::Destructor
- );
-
- sub _reconcile_with_superclass_meta {
- my($self, $other) = @_;
-
- # find incompatible traits
- my %metaroles;
- foreach my $metaclass_type(@MetaClassTypes){
- my $accessor = $self->can($metaclass_type . '_metaclass')
- || $self->can($metaclass_type . '_class');
-
- my $other_c = $other->$accessor();
- my $self_c = $self->$accessor();
-
- if(!$self_c->isa($other_c)){
- $metaroles{$metaclass_type}
- = [ $self_c->meta->_collect_roles($other_c->meta) ];
- }
- }
-
- $metaroles{class} = [$self->meta->_collect_roles($other->meta)];
-
- #use Data::Dumper; print Data::Dumper->new([\%metaroles], ['*metaroles'])->Indent(1)->Dump;
-
- require Mouse::Util::MetaRole;
- $_[0] = Mouse::Util::MetaRole::apply_metaroles(
- for => $self,
- class_metaroles => \%metaroles,
- );
- return;
- }
-
- sub _collect_roles {
- my ($self, $other) = @_;
-
- # find common ancestor
- my @self_lin_isa = $self->linearized_isa;
- my @other_lin_isa = $other->linearized_isa;
-
- my(@self_anon_supers, @other_anon_supers);
- push @self_anon_supers, shift @self_lin_isa while $self_lin_isa[0]->meta->is_anon_class;
- push @other_anon_supers, shift @other_lin_isa while $other_lin_isa[0]->meta->is_anon_class;
-
- my $common_ancestor = $self_lin_isa[0] eq $other_lin_isa[0] && $self_lin_isa[0];
-
- if(!$common_ancestor){
- $self->throw_error(sprintf '%s cannot have %s as a super class because of their metaclass incompatibility',
- $self->name, $other->name);
- }
-
- my %seen;
- return sort grep { !$seen{$_}++ } ## no critic
- (map{ $_->name } map{ $_->meta->calculate_all_roles } @self_anon_supers),
- (map{ $_->name } map{ $_->meta->calculate_all_roles } @other_anon_supers),
- ;
- }
-
-
- sub find_method_by_name{
- my($self, $method_name) = @_;
- defined($method_name)
- or $self->throw_error('You must define a method name to find');
-
- foreach my $class( $self->linearized_isa ){
- my $method = $self->initialize($class)->get_method($method_name);
- return $method if defined $method;
- }
- return undef;
- }
-
- sub get_all_methods {
- my($self) = @_;
- return map{ $self->find_method_by_name($_) } $self->get_all_method_names;
- }
-
- sub get_all_method_names {
- my $self = shift;
- my %uniq;
- return grep { $uniq{$_}++ == 0 }
- map { Mouse::Meta::Class->initialize($_)->get_method_list() }
- $self->linearized_isa;
- }
-
- sub find_attribute_by_name{
- my($self, $name) = @_;
- my $attr;
- foreach my $class($self->linearized_isa){
- my $meta = Mouse::Util::get_metaclass_by_name($class) or next;
- $attr = $meta->get_attribute($name) and last;
- }
- return $attr;
- }
-
- sub add_attribute {
- my $self = shift;
-
- my($attr, $name);
-
- if(blessed $_[0]){
- $attr = $_[0];
-
- $attr->isa('Mouse::Meta::Attribute')
- || $self->throw_error("Your attribute must be an instance of Mouse::Meta::Attribute (or a subclass)");
-
- $name = $attr->name;
- }
- else{
- # _process_attribute
- $name = shift;
-
- my %args = (@_ == 1) ? %{$_[0]} : @_;
-
- defined($name)
- or $self->throw_error('You must provide a name for the attribute');
-
- if ($name =~ s/^\+//) { # inherited attributes
- my $inherited_attr = $self->find_attribute_by_name($name)
- or $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name);
-
- $attr = $inherited_attr->clone_and_inherit_options(%args);
- }
- else{
- my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args);
- $args{traits} = \@traits if @traits;
-
- $attr = $attribute_class->new($name, %args);
- }
- }
-
- weaken( $attr->{associated_class} = $self );
-
- # install accessors first
- $attr->install_accessors();
-
- # then register the attribute to the metaclass
- $attr->{insertion_order} = keys %{ $self->{attributes} };
- $self->{attributes}{$attr->name} = $attr;
-
- if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){
- Carp::carp(qq{Attribute ($name) of class }.$self->name
- .qq{ has no associated methods (did you mean to provide an "is" argument?)});
- }
- return $attr;
- }
-
- sub compute_all_applicable_attributes { # DEPRECATED
- Carp::cluck('compute_all_applicable_attributes() has been deprecated. Use get_all_attributes() instead');
-
- return shift->get_all_attributes(@_)
- }
-
- sub linearized_isa;
-
- sub new_object;
- sub clone_object;
-
-
- sub clone_instance { # DEPRECATED
- my ($class, $instance, %params) = @_;
-
- Carp::cluck('clone_instance() has been deprecated. Use clone_object() instead');
-
- return $class->clone_object($instance, %params);
- }
-
-
- sub immutable_options {
- my ( $self, @args ) = @_;
-
- return (
- inline_constructor => 1,
- inline_destructor => 1,
- constructor_name => 'new',
- @args,
- );
- }
-
-
- sub make_immutable {
- my $self = shift;
- my %args = $self->immutable_options(@_);
-
- $self->{is_immutable}++;
-
- if ($args{inline_constructor}) {
- $self->add_method($args{constructor_name} =>
- Mouse::Util::load_class($self->constructor_class)
- ->_generate_constructor($self, \%args));
- }
-
- if ($args{inline_destructor}) {
- $self->add_method(DESTROY =>
- Mouse::Util::load_class($self->destructor_class)
- ->_generate_destructor($self, \%args));
- }
-
- # Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
- # at the end of a source file.
- return 1;
- }
-
- sub make_mutable {
- my($self) = @_;
- $self->{is_immutable} = 0;
- return;
- }
-
- sub is_immutable;
- sub is_mutable { !$_[0]->is_immutable }
-
- sub _install_modifier_pp{
- my( $self, $type, $name, $code ) = @_;
- my $into = $self->name;
-
- my $original = $into->can($name)
- or $self->throw_error("The method '$name' is not found in the inheritance hierarchy for class $into");
-
- my $modifier_table = $self->{modifiers}{$name};
-
- if(!$modifier_table){
- my(@before, @after, @around, $cache, $modified);
-
- $cache = $original;
-
- $modified = sub {
- for my $c (@before) { $c->(@_) }
-
- if(wantarray){ # list context
- my @rval = $cache->(@_);
-
- for my $c(@after){ $c->(@_) }
- return @rval;
- }
- elsif(defined wantarray){ # scalar context
- my $rval = $cache->(@_);
-
- for my $c(@after){ $c->(@_) }
- return $rval;
- }
- else{ # void context
- $cache->(@_);
-
- for my $c(@after){ $c->(@_) }
- return;
- }
- };
-
- $self->{modifiers}{$name} = $modifier_table = {
- original => $original,
-
- before => \@before,
- after => \@after,
- around => \@around,
-
- cache => \$cache, # cache for around modifiers
- };
-
- $self->add_method($name => $modified);
- }
-
- if($type eq 'before'){
- unshift @{$modifier_table->{before}}, $code;
- }
- elsif($type eq 'after'){
- push @{$modifier_table->{after}}, $code;
- }
- else{ # around
- push @{$modifier_table->{around}}, $code;
-
- my $next = ${ $modifier_table->{cache} };
- ${ $modifier_table->{cache} } = sub{ $code->($next, @_) };
- }
-
- return;
- }
-
- sub _install_modifier {
- my ( $self, $type, $name, $code ) = @_;
-
- # load Data::Util first
- my $no_cmm_fast = do{
- local $@;
- eval q{ use Data::Util 0.55 () };
- $@;
- };
-
- my $impl;
- if($no_cmm_fast){
- $impl = \&_install_modifier_pp;
- }
- else{
- $impl = sub {
- my ( $self, $type, $name, $code ) = @_;
- my $into = $self->name;
-
- my $method = Mouse::Util::get_code_ref( $into, $name );
-
- if ( !$method || !Data::Util::subroutine_modifier($method) ) {
- unless ($method) {
- $method = $into->can($name)
- or Carp::confess("The method '$name' is not found in the inheritance hierarchy for class $into");
- }
- $method = Data::Util::modify_subroutine( $method,
- $type => [$code] );
-
- $self->add_method($name => $method);
- }
- else {
- Data::Util::subroutine_modifier( $method, $type => $code );
- $self->add_method($name => Mouse::Util::get_code_ref($into, $name));
- }
-
- return;
- };
- }
-
- # replace this method itself :)
- {
- no warnings 'redefine';
- *_install_modifier = $impl;
- }
-
- $self->$impl( $type, $name, $code );
- }
-
- sub add_before_method_modifier {
- my ( $self, $name, $code ) = @_;
- $self->_install_modifier( 'before', $name, $code );
- }
-
- sub add_around_method_modifier {
- my ( $self, $name, $code ) = @_;
- $self->_install_modifier( 'around', $name, $code );
- }
-
- sub add_after_method_modifier {
- my ( $self, $name, $code ) = @_;
- $self->_install_modifier( 'after', $name, $code );
- }
-
- sub add_override_method_modifier {
- my ($self, $name, $code) = @_;
-
- if($self->has_method($name)){
- $self->throw_error("Cannot add an override method if a local method is already present");
- }
-
- my $package = $self->name;
-
- my $super_body = $package->can($name)
- or $self->throw_error("You cannot override '$name' because it has no super method");
-
- $self->add_method($name => sub {
- local $Mouse::SUPER_PACKAGE = $package;
- local $Mouse::SUPER_BODY = $super_body;
- local @Mouse::SUPER_ARGS = @_;
-
- $code->(@_);
- });
- return;
- }
-
- sub add_augment_method_modifier {
- my ($self, $name, $code) = @_;
- if($self->has_method($name)){
- $self->throw_error("Cannot add an augment method if a local method is already present");
- }
-
- my $super = $self->find_method_by_name($name)
- or $self->throw_error("You cannot augment '$name' because it has no super method");
-
- my $super_package = $super->package_name;
- my $super_body = $super->body;
-
- $self->add_method($name => sub{
- local $Mouse::INNER_BODY{$super_package} = $code;
- local $Mouse::INNER_ARGS{$super_package} = [@_];
- $super_body->(@_);
- });
- return;
- }
-
- sub does_role {
- my ($self, $role_name) = @_;
-
- (defined $role_name)
- || $self->throw_error("You must supply a role name to look for");
-
- $role_name = $role_name->name if ref $role_name;
-
- for my $class ($self->linearized_isa) {
- my $meta = Mouse::Util::get_metaclass_by_name($class)
- or next;
-
- for my $role (@{ $meta->roles }) {
-
- return 1 if $role->does_role($role_name);
- }
- }
-
- return 0;
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Method.pm
- package Mouse::Meta::Method;
- use Mouse::Util qw(:meta); # enables strict and warnings
- use Scalar::Util ();
-
- use overload
- '==' => '_equal',
- 'eq' => '_equal',
- '&{}' => sub{ $_[0]->body },
- fallback => 1,
- ;
-
- sub wrap{
- my $class = shift;
-
- return $class->_new(@_);
- }
-
- sub _new{
- my($class, %args) = @_;
- my $self = bless \%args, $class;
-
- if($class ne __PACKAGE__){
- $self->meta->_initialize_object($self, \%args);
- }
- return $self;
- }
-
- sub body { $_[0]->{body} }
- sub name { $_[0]->{name} }
- sub package_name { $_[0]->{package} }
- sub associated_metaclass { $_[0]->{associated_metaclass} }
-
- sub fully_qualified_name {
- my($self) = @_;
- return $self->package_name . '::' . $self->name;
- }
-
- # for Moose compat
- sub _equal {
- my($l, $r) = @_;
-
- return Scalar::Util::blessed($r)
- && $l->body == $r->body
- && $l->name eq $r->name
- && $l->package_name eq $r->package_name;
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Method/Accessor.pm
- package Mouse::Meta::Method::Accessor;
- use Mouse::Util qw(:meta); # enables strict and warnings
-
- sub _inline_slot{
- my(undef, $self_var, $attr_name) = @_;
- return sprintf '%s->{q{%s}}', $self_var, $attr_name;
- }
-
- sub _generate_accessor_any{
- my($method_class, $type, $attribute, $class) = @_;
-
- my $name = $attribute->name;
- my $default = $attribute->default;
- my $constraint = $attribute->type_constraint;
- my $builder = $attribute->builder;
- my $trigger = $attribute->trigger;
- my $is_weak = $attribute->is_weak_ref;
- my $should_deref = $attribute->should_auto_deref;
- my $should_coerce = (defined($constraint) && $constraint->has_coercion && $attribute->should_coerce);
-
- my $compiled_type_constraint = defined($constraint) ? $constraint->_compiled_type_constraint : undef;
-
- my $self = '$_[0]';
- my $slot = $method_class->_inline_slot($self, $name);;
-
- my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__)
- . "sub {\n";
-
- if ($type eq 'rw' || $type eq 'wo') {
- if($type eq 'rw'){
- $accessor .=
- 'if (scalar(@_) >= 2) {' . "\n";
- }
- else{ # writer
- $accessor .=
- 'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'.
- '{' . "\n";
- }
-
- my $value = '$_[1]';
-
- if (defined $constraint) {
- if ($should_coerce) {
- $accessor .=
- "\n".
- 'my $val = $constraint->coerce('.$value.');';
- $value = '$val';
- }
- $accessor .=
- "\n".
- '$compiled_type_constraint->('.$value.') or
- $attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n";
- }
-
- # if there's nothing left to do for the attribute we can return during
- # this setter
- $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref;
-
- $accessor .= "$slot = $value;\n";
-
- if ($is_weak) {
- $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
- }
-
- if ($trigger) {
- $accessor .= '$trigger->('.$self.', '.$value.');' . "\n";
- }
-
- $accessor .= "}\n";
- }
- elsif($type eq 'ro') {
- $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n";
- }
- else{
- $class->throw_error("Unknown accessor type '$type'");
- }
-
- if ($attribute->is_lazy and $type ne 'wo') {
- my $value;
-
- if (defined $builder){
- $value = "$self->\$builder()";
- }
- elsif (ref($default) eq 'CODE'){
- $value = "$self->\$default()";
- }
- else{
- $value = '$default';
- }
-
- $accessor .= "els" if $type eq 'rw';
- $accessor .= "if(!exists $slot){\n";
- if($should_coerce){
- $accessor .= "$slot = \$constraint->coerce($value)";
- }
- elsif(defined $constraint){
- $accessor .= "my \$tmp = $value;\n";
-
- $accessor .= "\$compiled_type_constraint->(\$tmp)";
- $accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n";
- $accessor .= "$slot = \$tmp;\n";
- }
- else{
- $accessor .= "$slot = $value;\n";
- }
- if ($is_weak) {
- $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
- }
- $accessor .= "}\n";
- }
-
- if ($should_deref) {
- if ($constraint->is_a_type_of('ArrayRef')) {
- $accessor .= "return \@{ $slot || [] } if wantarray;\n";
- }
- elsif($constraint->is_a_type_of('HashRef')){
- $accessor .= "return \%{ $slot || {} } if wantarray;\n";
- }
- else{
- $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name);
- }
- }
-
- $accessor .= "return $slot;\n}\n";
-
- #print $accessor, "\n";
- my $code;
- my $e = do{
- local $@;
- $code = eval $accessor;
- $@;
- };
- die $e if $e;
-
- return $code;
- }
-
- sub _generate_accessor{
- #my($self, $attribute, $metaclass) = @_;
- my $self = shift;
- return $self->_generate_accessor_any(rw => @_);
- }
-
- sub _generate_reader {
- #my($self, $attribute, $metaclass) = @_;
- my $self = shift;
- return $self->_generate_accessor_any(ro => @_);
- }
-
- sub _generate_writer {
- #my($self, $attribute, $metaclass) = @_;
- my $self = shift;
- return $self->_generate_accessor_any(wo => @_);
- }
-
- sub _generate_predicate {
- #my($self, $attribute, $metaclass) = @_;
- my(undef, $attribute) = @_;
-
- my $slot = $attribute->name;
- return sub{
- return exists $_[0]->{$slot};
- };
- }
-
- sub _generate_clearer {
- #my($self, $attribute, $metaclass) = @_;
- my(undef, $attribute) = @_;
-
- my $slot = $attribute->name;
- return sub{
- delete $_[0]->{$slot};
- };
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Method/Constructor.pm
- package Mouse::Meta::Method::Constructor;
- use Mouse::Util qw(:meta); # enables strict and warnings
-
- sub _inline_slot{
- my(undef, $self_var, $attr_name) = @_;
- return sprintf '%s->{q{%s}}', $self_var, $attr_name;
- }
-
- sub _generate_constructor {
- my ($class, $metaclass, $args) = @_;
-
- my $associated_metaclass_name = $metaclass->name;
-
- my @attrs = $metaclass->get_all_attributes;
-
- my $buildall = $class->_generate_BUILDALL($metaclass);
- my $buildargs = $class->_generate_BUILDARGS($metaclass);
- my $processattrs = $class->_generate_processattrs($metaclass, \@attrs);
-
- my @checks = map { $_ && $_->_compiled_type_constraint }
- map { $_->type_constraint } @attrs;
-
- my $source = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"...";
- sub \{
- my \$class = shift;
- return \$class->Mouse::Object::new(\@_)
- if \$class ne q{$associated_metaclass_name};
- # BUILDARGS
- $buildargs;
- my \$instance = bless {}, \$class;
- # process attributes
- $processattrs;
- # BUILDALL
- $buildall;
- return \$instance;
- }
- ...
- #warn $source;
- my $code;
- my $e = do{
- local $@;
- $code = eval $source;
- $@;
- };
- die $e if $e;
- return $code;
- }
-
- sub _generate_processattrs {
- my ($method_class, $metaclass, $attrs) = @_;
- my @res;
-
- my $has_triggers;
- my $strict = $metaclass->strict_constructor;
-
- if($strict){
- push @res, 'my $used = 0;';
- }
-
- for my $index (0 .. @$attrs - 1) {
- my $code = '';
-
- my $attr = $attrs->[$index];
- my $key = $attr->name;
-
- my $init_arg = $attr->init_arg;
- my $type_constraint = $attr->type_constraint;
- my $is_weak_ref = $attr->is_weak_ref;
- my $need_coercion;
-
- my $instance_slot = $method_class->_inline_slot('$instance', $key);
- my $attr_var = "\$attrs[$index]";
- my $constraint_var;
-
- if(defined $type_constraint){
- $constraint_var = "$attr_var\->{type_constraint}";
- $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion);
- }
-
- $code .= "# initialize $key\n";
-
- my $post_process = '';
- if(defined $type_constraint){
- $post_process .= "\$checks[$index]->($instance_slot)";
- $post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n";
- }
- if($is_weak_ref){
- $post_process .= "Scalar::Util::weaken($instance_slot) if ref $instance_slot;\n";
- }
-
- if (defined $init_arg) {
- my $value = "\$args->{q{$init_arg}}";
-
- $code .= "if (exists $value) {\n";
-
- if($need_coercion){
- $value = "$constraint_var->coerce($value)";
- }
-
- $code .= "$instance_slot = $value;\n";
- $code .= $post_process;
-
- if ($attr->has_trigger) {
- $has_triggers++;
- $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n";
- }
-
- if ($strict){
- $code .= '++$used;' . "\n";
- }
-
- $code .= "\n} else {\n"; # $value exists
- }
-
- if ($attr->has_default || $attr->has_builder) {
- unless ($attr->is_lazy) {
- my $default = $attr->default;
- my $builder = $attr->builder;
-
- my $value;
- if (defined($builder)) {
- $value = "\$instance->$builder()";
- }
- elsif (ref($default) eq 'CODE') {
- $value = "$attr_var\->{default}->(\$instance)";
- }
- elsif (defined($default)) {
- $value = "$attr_var\->{default}";
- }
- else {
- $value = 'undef';
- }
-
- if($need_coercion){
- $value = "$constraint_var->coerce($value)";
- }
-
- $code .= "$instance_slot = $value;\n";
- if($is_weak_ref){
- $code .= "Scalar::Util::weaken($instance_slot);\n";
- }
- }
- }
- elsif ($attr->is_required) {
- $code .= "Carp::confess('Attribute ($key) is required');";
- }
-
- $code .= "}\n" if defined $init_arg;
-
- push @res, $code;
- }
-
- if($strict){
- push @res, q{if($used < keys %{$args})}
- . q{{ $metaclass->_report_unknown_args(\@attrs, $args) }};
- }
-
- if($metaclass->is_anon_class){
- push @res, q{$instance->{__METACLASS__} = $metaclass;};
- }
-
- if($has_triggers){
- unshift @res, q{my @triggers;};
- push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
- }
-
- return join "\n", @res;
- }
-
- sub _generate_BUILDARGS {
- my(undef, $metaclass) = @_;
-
- my $class = $metaclass->name;
- if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) {
- return 'my $args = $class->BUILDARGS(@_)';
- }
-
- return <<'...';
- my $args;
- if ( scalar @_ == 1 ) {
- ( ref( $_[0] ) eq 'HASH' )
- || Carp::confess "Single parameters to new() must be a HASH ref";
- $args = +{ %{ $_[0] } };
- }
- else {
- $args = +{@_};
- }
- ...
- }
-
- sub _generate_BUILDALL {
- my (undef, $metaclass) = @_;
-
- return '' unless $metaclass->name->can('BUILD');
-
- my @code;
- for my $class ($metaclass->linearized_isa) {
- if (Mouse::Util::get_code_ref($class, 'BUILD')) {
- unshift @code, qq{${class}::BUILD(\$instance, \$args);};
- }
- }
- return join "\n", @code;
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Method/Delegation.pm
- package Mouse::Meta::Method::Delegation;
- use Mouse::Util qw(:meta); # enables strict and warnings
- use Scalar::Util;
-
- sub _generate_delegation{
- my (undef, $attr, $handle_name, $method_to_call) = @_;
-
- my @curried_args;
- if(ref($method_to_call) eq 'ARRAY'){
- ($method_to_call, @curried_args) = @{$method_to_call};
- }
-
- my $reader = $attr->get_read_method_ref();
-
- my $can_be_optimized = $attr->{_method_delegation_can_be_optimized};
-
- if(!defined $can_be_optimized){
- my $tc = $attr->type_constraint;
-
- $attr->{_method_delegation_can_be_optimized} =
- (defined($tc) && $tc->is_a_type_of('Object'))
- && ($attr->is_required || $attr->has_default || $attr->has_builder)
- && ($attr->is_lazy || !$attr->has_clearer);
- }
-
- if($can_be_optimized){
- # need not check the attribute value
- return sub {
- return shift()->$reader()->$method_to_call(@curried_args, @_);
- };
- }
- else {
- # need to check the attribute value
- return sub {
- my $instance = shift;
- my $proxy = $instance->$reader();
-
- my $error = !defined($proxy) ? ' is not defined'
- : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')}
- : undef;
- if ($error) {
- $instance->meta->throw_error(
- "Cannot delegate $handle_name to $method_to_call because "
- . "the value of "
- . $attr->name
- . $error
- );
- }
- $proxy->$method_to_call(@curried_args, @_);
- };
- }
- }
-
-
- }
- BEGIN{ # lib/Mouse/Meta/Method/Destructor.pm
- package Mouse::Meta::Method::Destructor;
- use Mouse::Util qw(:meta); # enables strict and warnings
-
- sub _empty_DESTROY{ }
-
- sub _generate_destructor{
- my (undef, $metaclass) = @_;
-
- if(!$metaclass->name->can('DEMOLISH')){
- return \&_empty_DESTROY;
- }
-
- my $demolishall = '';
- for my $class ($metaclass->linearized_isa) {
- if (Mouse::Util::get_code_ref($class, 'DEMOLISH')) {
- $demolishall .= sprintf "%s::DEMOLISH(\$self, \$Mouse::Util::in_global_destruction);\n",
- $class,
- }
- }
-
- my $source = sprintf(<<'END_DESTROY', __LINE__, __FILE__, $demolishall);
- #line %d %s
- sub {
- my $self = shift;
- my $e = do{
- local $?;
- local $@;
- eval{
- # demolishall
- %s;
- };
- $@;
- };
- no warnings 'misc';
- die $e if $e; # rethrow
- }
- END_DESTROY
-
- my $code;
- my $e = do{
- local $@;
- $code = eval $source;
- $@;
- };
- die $e if $e;
- return $code;
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Module.pm
- package Mouse::Meta::Module;
- use Mouse::Util qw/:meta get_code_package get_code_ref not_supported/; # enables strict and warnings
-
- use Carp ();
- use Scalar::Util ();
-
- my %METAS;
-
- if(Mouse::Util::MOUSE_XS){
- # register meta storage for performance
- Mouse::Util::__register_metaclass_storage(\%METAS, 0);
-
- # ensure thread safety
- *CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) };
- }
-
- sub _metaclass_cache { # DEPRECATED
- my($self, $name) = @_;
- Carp::cluck('_metaclass_cache() has been deprecated. Use Mouse::Util::get_metaclass_by_name() instead');
- return $METAS{$name};
- }
-
- sub initialize {
- my($class, $package_name, @args) = @_;
-
- ($package_name && !ref($package_name))
- || $class->throw_error("You must pass a package name and it cannot be blessed");
-
- return $METAS{$package_name}
- ||= $class->_construct_meta(package => $package_name, @args);
- }
-
- sub reinitialize {
- my($class, $package_name, @args) = @_;
-
- $package_name = $package_name->name if ref $package_name;
-
- ($package_name && !ref($package_name))
- || $class->throw_error("You must pass a package name and it cannot be blessed");
-
- delete $METAS{$package_name};
- return $class->initialize($package_name, @args);
- }
-
- sub _class_of{
- my($class_or_instance) = @_;
- return undef unless defined $class_or_instance;
- return $METAS{ ref($class_or_instance) || $class_or_instance };
- }
-
- # Means of accessing all the metaclasses that have
- # been initialized thus far
- #sub _get_all_metaclasses { %METAS }
- sub _get_all_metaclass_instances { values %METAS }
- sub _get_all_metaclass_names { keys %METAS }
- sub _get_metaclass_by_name { $METAS{$_[0]} }
- #sub _store_metaclass_by_name { $METAS{$_[0]} = $_[1] }
- #sub _weaken_metaclass { weaken($METAS{$_[0]}) }
- #sub _does_metaclass_exist { defined $METAS{$_[0]} }
- #sub _remove_metaclass_by_name { delete $METAS{$_[0]} }
-
- sub name;
-
- sub namespace;
-
- # add_attribute is an abstract method
-
- sub get_attribute_map { # DEPRECATED
- Carp::cluck('get_attribute_map() has been deprecated. Use get_attribute_list() and get_attribute() instead');
- return $_[0]->{attributes};
- }
-
- sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
- sub get_attribute { $_[0]->{attributes}->{$_[1]} }
- sub remove_attribute { delete $_[0]->{attributes}->{$_[1]} }
-
- sub get_attribute_list{ keys %{$_[0]->{attributes}} }
-
- # XXX: for backward compatibility
- my %foreign = map{ $_ => undef } qw(
- Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints
- Carp Scalar::Util List::Util
- );
- sub _code_is_mine{
- # my($self, $code) = @_;
-
- return !exists $foreign{ get_code_package($_[1]) };
- }
-
- sub add_method;
-
- sub has_method {
- my($self, $method_name) = @_;
-
- defined($method_name)
- or $self->throw_error('You must define a method name');
-
- return defined($self->{methods}{$method_name}) || do{
- my $code = get_code_ref($self->{package}, $method_name);
- $code && $self->_code_is_mine($code);
- };
- }
-
- sub get_method_body {
- my($self, $method_name) = @_;
-
- defined($method_name)
- or $self->throw_error('You must define a method name');
-
- return $self->{methods}{$method_name} ||= do{
- my $code = get_code_ref($self->{package}, $method_name);
- $code && $self->_code_is_mine($code) ? $code : undef;
- };
- }
-
- sub get_method{
- my($self, $method_name) = @_;
-
- if(my $code = $self->get_method_body($method_name)){
- return Mouse::Util::load_class($self->method_metaclass)->wrap(
- body => $code,
- name => $method_name,
- package => $self->name,
- associated_metaclass => $self,
- );
- }
-
- return undef;
- }
-
- sub get_method_list {
- my($self) = @_;
-
- return grep { $self->has_method($_) } keys %{ $self->namespace };
- }
-
- sub _collect_methods { # Mouse specific
- my($meta, @args) = @_;
-
- my @methods;
- foreach my $arg(@args){
- if(my $type = ref $arg){
- if($type eq 'Regexp'){
- push @methods, grep { $_ =~ $arg } $meta->get_all_method_names;
- }
- elsif($type eq 'ARRAY'){
- push @methods, @{$arg};
- }
- else{
- my $subname = ( caller(1) )[3];
- $meta->throw_error(
- sprintf(
- 'Methods passed to %s must be provided as a list, ArrayRef or regular expression, not %s',
- $subname,
- $type,
- )
- );
- }
- }
- else{
- push @methods, $arg;
- }
- }
- return @methods;
- }
-
- my $ANON_SERIAL = 0; # anonymous class/role id
- my %IMMORTALS; # immortal anonymous classes
-
- sub create {
- my($self, $package_name, %options) = @_;
-
- my $class = ref($self) || $self;
- $self->throw_error('You must pass a package name') if @_ < 2;
-
- my $superclasses;
- if(exists $options{superclasses}){
- if(Mouse::Util::is_a_metarole($self)){
- delete $options{superclasses};
- }
- else{
- $superclasses = delete $options{superclasses};
- (ref $superclasses eq 'ARRAY')
- || $self->throw_error("You must pass an ARRAY ref of superclasses");
- }
- }
-
- my $attributes = delete $options{attributes};
- if(defined $attributes){
- (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
- || $self->throw_error("You must pass an ARRAY ref of attributes");
- }
- my $methods = delete $options{methods};
- if(defined $methods){
- (ref $methods eq 'HASH')
- || $self->throw_error("You must pass a HASH ref of methods");
- }
- my $roles = delete $options{roles};
- if(defined $roles){
- (ref $roles eq 'ARRAY')
- || $self->throw_error("You must pass an ARRAY ref of roles");
- }
- my $mortal;
- my $cache_key;
-
- if(!defined $package_name){ # anonymous
- $mortal = !$options{cache};
-
- # anonymous but immortal
- if(!$mortal){
- # something like Super::Class|Super::Class::2=Role|Role::1
- $cache_key = join '=' => (
- join('|', @{$superclasses || []}),
- join('|', sort @{$roles || []}),
- );
- return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
- }
- $options{anon_serial_id} = ++$ANON_SERIAL;
- $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
- }
-
- # instantiate a module
- {
- no strict 'refs';
- ${ $package_name . '::VERSION' } = delete $options{version} if exists $options{version};
- ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
- }
-
- my $meta = $self->initialize( $package_name, %options);
-
- Scalar::Util::weaken $METAS{$package_name}
- if $mortal;
-
- $meta->add_method(meta => sub {
- $self->initialize(ref($_[0]) || $_[0]);
- });
-
- $meta->superclasses(@{$superclasses})
- if defined $superclasses;
-
- # NOTE:
- # process attributes first, so that they can
- # install accessors, but locally defined methods
- # can then overwrite them. It is maybe a little odd, but
- # I think this should be the order of things.
- if (defined $attributes) {
- if(ref($attributes) eq 'ARRAY'){
- # array of Mouse::Meta::Attribute
- foreach my $attr (@{$attributes}) {
- $meta->add_attribute($attr);
- }
- }
- else{
- # hash map of name and attribute spec pairs
- while(my($name, $attr) = each %{$attributes}){
- $meta->add_attribute($name => $attr);
- }
- }
- }
- if (defined $methods) {
- while(my($method_name, $method_body) = each %{$methods}){
- $meta->add_method($method_name, $method_body);
- }
- }
- if (defined $roles){
- Mouse::Util::apply_all_roles($package_name, @{$roles});
- }
-
- if($cache_key){
- $IMMORTALS{$cache_key} = $meta;
- }
-
- return $meta;
- }
-
- sub DESTROY{
- my($self) = @_;
-
- return if $Mouse::Util::in_global_destruction;
-
- my $serial_id = $self->{anon_serial_id};
-
- return if !$serial_id;
- # mortal anonymous class
-
- # XXX: cleaning stash with threads causes panic/SEGV.
- if(exists $INC{'threads.pm'}) {
- # (caller)[2] indicates the caller's line number,
- # which is zero when the current thread is joining.
- return if( (caller)[2] == 0);
- }
-
- # @ISA is a magical variable, so we clear it manually.
- @{$self->{superclasses}} = () if exists $self->{superclasses};
-
- # Then, clear the symbol table hash
- %{$self->namespace} = ();
-
- my $name = $self->name;
- delete $METAS{$name};
-
- $name =~ s/ $serial_id \z//xms;
- no strict 'refs';
- delete ${$name}{ $serial_id . '::' };
-
- return;
- }
-
- sub throw_error{
- my($self, $message, %args) = @_;
-
- local $Carp::CarpLevel = $Carp::CarpLevel + 1 + ($args{depth} || 0);
- local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
-
- if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0
- Carp::croak($message);
- }
- else{
- Carp::confess($message);
- }
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Role.pm
- package Mouse::Meta::Role;
- use Mouse::Util qw(:meta not_supported); # enables strict and warnings
-
- use Mouse::Meta::Module;
- our @ISA = qw(Mouse::Meta::Module);
-
- sub method_metaclass;
-
- sub _construct_meta {
- my $class = shift;
-
- my %args = @_;
-
- $args{methods} = {};
- $args{attributes} = {};
- $args{required_methods} = [];
- $args{roles} = [];
-
- my $self = bless \%args, ref($class) || $class;
- if($class ne __PACKAGE__){
- $self->meta->_initialize_object($self, \%args);
- }
-
- return $self;
- }
-
- sub create_anon_role{
- my $self = shift;
- return $self->create(undef, @_);
- }
-
- sub is_anon_role;
-
- sub get_roles;
-
- sub calculate_all_roles {
- my $self = shift;
- my %seen;
- return grep { !$seen{ $_->name }++ }
- ($self, map { $_->calculate_all_roles } @{ $self->get_roles });
- }
-
- sub get_required_method_list{
- return @{ $_[0]->{required_methods} };
- }
-
- sub add_required_methods {
- my($self, @methods) = @_;
- my %required = map{ $_ => 1 } @{$self->{required_methods}};
- push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods;
- return;
- }
-
- sub requires_method {
- my($self, $name) = @_;
- return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
- }
-
- sub add_attribute {
- my $self = shift;
- my $name = shift;
-
- $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
- return;
- }
-
- sub _check_required_methods{
- my($role, $consumer, $args) = @_;
-
- if($args->{_to} eq 'role'){
- $consumer->add_required_methods($role->get_required_method_list);
- }
- else{ # to class or instance
- my $consumer_class_name = $consumer->name;
-
- my @missing;
- foreach my $method_name(@{$role->{required_methods}}){
- next if exists $args->{aliased_methods}{$method_name};
- next if exists $role->{methods}{$method_name};
- next if $consumer_class_name->can($method_name);
-
- push @missing, $method_name;
- }
- if(@missing){
- $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
- $role->name,
- (@missing == 1 ? '' : 's'), # method or methods
- Mouse::Util::quoted_english_list(@missing),
- $consumer_class_name);
- }
- }
-
- return;
- }
-
- sub _apply_methods{
- my($role, $consumer, $args) = @_;
-
- my $alias = $args->{-alias};
- my $excludes = $args->{-excludes};
-
- foreach my $method_name($role->get_method_list){
- next if $method_name eq 'meta';
-
- my $code = $role->get_method_body($method_name);
-
- if(!exists $excludes->{$method_name}){
- if(!$consumer->has_method($method_name)){
- # The third argument $role is used in Role::Composite
- $consumer->add_method($method_name => $code, $role);
- }
- }
-
- if(exists $alias->{$method_name}){
- my $dstname = $alias->{$method_name};
-
- my $dstcode = $consumer->get_method_body($dstname);
-
- if(defined($dstcode) && $dstcode != $code){
- $role->throw_error("Cannot create a method alias if a local method of the same name exists");
- }
- else{
- $consumer->add_method($dstname => $code, $role);
- }
- }
- }
-
- return;
- }
-
- sub _apply_attributes{
- #my($role, $consumer, $args) = @_;
- my($role, $consumer) = @_;
-
- for my $attr_name ($role->get_attribute_list) {
- next if $consumer->has_attribute($attr_name);
-
- $consumer->add_attribute($attr_name => $role->get_attribute($attr_name));
- }
- return;
- }
-
- sub _apply_modifiers{
- #my($role, $consumer, $args) = @_;
- my($role, $consumer) = @_;
-
-
- if(my $modifiers = $role->{override_method_modifiers}){
- foreach my $method_name (keys %{$modifiers}){
- $consumer->add_override_method_modifier($method_name => $modifiers->{$method_name});
- }
- }
-
- for my $modifier_type (qw/before around after/) {
- my $table = $role->{"${modifier_type}_method_modifiers"}
- or next;
-
- my $add_modifier = "add_${modifier_type}_method_modifier";
-
- while(my($method_name, $modifiers) = each %{$table}){
- foreach my $code(@{ $modifiers }){
- next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers
- $consumer->$add_modifier($method_name => $code);
- }
- }
- }
- return;
- }
-
- sub _append_roles{
- #my($role, $consumer, $args) = @_;
- my($role, $consumer) = @_;
-
- my $roles = $consumer->{roles};
-
- foreach my $r($role, @{$role->get_roles}){
- if(!$consumer->does_role($r)){
- push @{$roles}, $r;
- }
- }
- return;
- }
-
- # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
- sub apply {
- my $self = shift;
- my $consumer = shift;
-
- my %args = (@_ == 1) ? %{ $_[0] } : @_;
-
- my $instance;
-
- if(Mouse::Util::is_a_metaclass($consumer)){ # Application::ToClass
- $args{_to} = 'class';
- }
- elsif(Mouse::Util::is_a_metarole($consumer)){ # Application::ToRole
- $args{_to} = 'role';
- }
- else{ # Appplication::ToInstance
- $args{_to} = 'instance';
- $instance = $consumer;
-
- $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')->create_anon_class(
- superclasses => [ref $instance],
- cache => 1,
- );
- }
-
- if($args{alias} && !exists $args{-alias}){
- $args{-alias} = $args{alias};
- }
- if($args{excludes} && !exists $args{-excludes}){
- $args{-excludes} = $args{excludes};
- }
-
- $args{aliased_methods} = {};
- if(my $alias = $args{-alias}){
- @{$args{aliased_methods}}{ values %{$alias} } = ();
- }
-
- if(my $excludes = $args{-excludes}){
- $args{-excludes} = {}; # replace with a hash ref
- if(ref $excludes){
- %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
- }
- else{
- $args{-excludes}{$excludes} = undef;
- }
- }
-
- $self->_check_required_methods($consumer, \%args);
- $self->_apply_attributes($consumer, \%args);
- $self->_apply_methods($consumer, \%args);
- $self->_apply_modifiers($consumer, \%args);
- $self->_append_roles($consumer, \%args);
-
-
- if(defined $instance){ # Application::ToInstance
- # rebless instance
- bless $instance, $consumer->name;
- $consumer->_initialize_object($instance, $instance, 1);
- }
-
- return;
- }
-
-
- sub combine {
- my($self, @role_specs) = @_;
-
- require 'Mouse/Meta/Role/Composite.pm'; # we don't want to create its namespace
-
- my $composite = Mouse::Meta::Role::Composite->create_anon_role();
-
- foreach my $role_spec (@role_specs) {
- my($role_name, $args) = @{$role_spec};
- $role_name->meta->apply($composite, %{$args});
- }
- return $composite;
- }
-
- sub add_before_method_modifier;
- sub add_around_method_modifier;
- sub add_after_method_modifier;
-
- sub get_before_method_modifiers;
- sub get_around_method_modifiers;
- sub get_after_method_modifiers;
-
- sub add_override_method_modifier{
- my($self, $method_name, $method) = @_;
-
- if($self->has_method($method_name)){
- # This error happens in the override keyword or during role composition,
- # so I added a message, "A local method of ...", only for compatibility (gfx)
- $self->throw_error("Cannot add an override of method '$method_name' "
- . "because there is a local version of '$method_name'"
- . "(A local method of the same name as been found)");
- }
-
- $self->{override_method_modifiers}->{$method_name} = $method;
- }
-
- sub get_override_method_modifier {
- my ($self, $method_name) = @_;
- return $self->{override_method_modifiers}->{$method_name};
- }
-
- sub does_role {
- my ($self, $role_name) = @_;
-
- (defined $role_name)
- || $self->throw_error("You must supply a role name to look for");
-
- $role_name = $role_name->name if ref $role_name;
-
- # if we are it,.. then return true
- return 1 if $role_name eq $self->name;
- # otherwise.. check our children
- for my $role (@{ $self->get_roles }) {
- return 1 if $role->does_role($role_name);
- }
- return 0;
- }
-
- }
- BEGIN{ # lib/Mouse/Meta/Role/Composite.pm
- package Mouse::Meta::Role::Composite;
- use Mouse::Util; # enables strict and warnings
- use Mouse::Meta::Role;
- our @ISA = qw(Mouse::Meta::Role);
-
- sub get_method_list{
- my($self) = @_;
- return keys %{ $self->{methods} };
- }
-
- sub add_method {
- my($self, $method_name, $code, $role) = @_;
-
- if( ($self->{methods}{$method_name} || 0) == $code){
- # This role already has the same method.
- return;
- }
-
- if($method_name eq 'meta'){
- $self->SUPER::add_method($method_name => $code);
- }
- else{
- # no need to add a subroutine to the stash
- my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
- push @{$roles}, $role;
- if(@{$roles} > 1){
- $self->{conflicting_methods}{$method_name}++;
- }
- $self->{methods}{$method_name} = $code;
- }
- return;
- }
-
- sub get_method_body {
- my($self, $method_name) = @_;
- return $self->{methods}{$method_name};
- }
-
- sub has_method {
- # my($self, $method_name) = @_;
- return 0; # to fool _apply_methods() in combine()
- }
-
- sub has_attribute{
- # my($self, $method_name) = @_;
- return 0; # to fool _appply_attributes() in combine()
- }
-
- sub has_override_method_modifier{
- # my($self, $method_name) = @_;
- return 0; # to fool _apply_modifiers() in combine()
- }
-
- sub add_attribute{
- my $self = shift;
- my $attr_name = shift;
- my $spec = (@_ == 1 ? $_[0] : {@_});
-
- my $existing = $self->{attributes}{$attr_name};
- if($existing && $existing != $spec){
- $self->throw_error("We have encountered an attribute conflict with '$attr_name' "
- . "during composition. This is fatal error and cannot be disambiguated.");
- }
- $self->SUPER::add_attribute($attr_name, $spec);
- return;
- }
-
- sub add_override_method_modifier{
- my($self, $method_name, $code) = @_;
-
- my $existing = $self->{override_method_modifiers}{$method_name};
- if($existing && $existing != $code){
- $self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
- . "composition (Two 'override' methods of the same name encountered). "
- . "This is fatal error.")
- }
- $self->SUPER::add_override_method_modifier($method_name, $code);
- return;
- }
-
- # components of apply()
-
- sub _apply_methods{
- my($self, $consumer, $args) = @_;
-
- if(exists $self->{conflicting_methods}){
- my $consumer_class_name = $consumer->name;
-
- my @conflicting = grep{ !$consumer_class_name->can($_) } keys %{ $self->{conflicting_methods} };
-
- if(@conflicting == 1){
- my $method_name = $conflicting[0];
- my $roles = Mouse::Util::quoted_english_list(map{ $_->name } @{ $self->{composed_roles_by_method}{$method_name} });
- $self->throw_error(
- sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
- $roles, $method_name, $consumer_class_name
- );
- }
- elsif(@conflicting > 1){
- my %seen;
- my $roles = Mouse::Util::quoted_english_list(
- grep{ !$seen{$_}++ } # uniq
- map { $_->name }
- map { @{$_} } @{ $self->{composed_roles_by_method} }{@conflicting}
- );
-
- $self->throw_error(
- sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
- $roles,
- Mouse::Util::quoted_english_list(@conflicting),
- $consumer_class_name
- );
- }
- }
-
- $self->SUPER::_apply_methods($consumer, $args);
- return;
- }
- }
- BEGIN{ # lib/Mouse/Meta/Role/Method.pm
- package Mouse::Meta::Role::Method;
- use Mouse::Util; # enables strict and warnings
-
- use Mouse::Meta::Method;
- our @ISA = qw(Mouse::Meta::Method);
-
- sub _new{
- my($class, %args) = @_;
- my $self = bless \%args, $class;
-
- if($class ne __PACKAGE__){
- $self->meta->_initialize_object($self, \%args);
- }
- return $self;
- }
-
- }
- BEGIN{ # lib/Mouse/Object.pm
- package Mouse::Object;
- use Mouse::Util qw(does dump meta); # enables strict and warnings
-
- sub new;
- sub BUILDARGS;
- sub BUILDALL;
-
- sub DESTROY;
- sub DEMOLISHALL;
-
- }
- BEGIN{ # lib/Mouse/Role.pm
- package Mouse::Role;
- use Mouse::Exporter; # enables strict and warnings
-
- our $VERSION = '0.64';
-
- use Carp qw(confess);
- use Scalar::Util qw(blessed);
-
- use Mouse::Util qw(not_supported);
- use Mouse::Meta::Role;
- use Mouse ();
-
- Mouse::Exporter->setup_import_methods(
- as_is => [qw(
- extends with
- has
- before after around
- override super
- augment inner
-
- requires excludes
- ),
- \&Scalar::Util::blessed,
- \&Carp::confess,
- ],
- );
-
-
- sub extends {
- Carp::croak "Roles do not support 'extends'";
- }
-
- sub with {
- my $meta = Mouse::Meta::Role->initialize(scalar caller);
- Mouse::Util::apply_all_roles($meta->name, @_);
- return;
- }
-
- sub has {
- my $meta = Mouse::Meta::Role->initialize(scalar caller);
- my $name = shift;
-
- $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
- if @_ % 2; # odd number of arguments
-
- if(ref $name){ # has [qw(foo bar)] => (...)
- for (@{$name}){
- $meta->add_attribute($_ => @_);
- }
- }
- else{ # has foo => (...)
- $meta->add_attribute($name => @_);
- }
- return;
- }
-
- sub before {
- my $meta = Mouse::Meta::Role->initialize(scalar caller);
- my $code = pop;
- for my $name($meta->_collect_methods(@_)) {
- $meta->add_before_method_modifier($name => $code);
- }
- return;
- }
-
- sub after {
- my $meta = Mouse::Meta::Role->initialize(scalar caller);
- my $code = pop;
- for my $name($meta->_collect_methods(@_)) {
- $meta->add_after_method_modifier($name => $code);
- }
- return;
- }
-
- sub around {
- my $meta = Mouse::Meta::Role->initialize(scalar caller);
- my $code = pop;
- for my $name($meta->_collect_methods(@_)) {
- $meta->add_around_method_modifier($name => $code);
- }
- return;
- }
-
-
- sub super {
- return if !defined $Mouse::SUPER_BODY;
- $Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS);
- }
-
- sub override {
- # my($name, $code) = @_;
- Mouse::Meta::Role->initialize(scalar caller)->add_override_method_modifier(@_);
- return;
- }
-
- # We keep the same errors messages as Moose::Role emits, here.
- sub inner {
- Carp::croak "Roles cannot support 'inner'";
- }
-
- sub augment {
- Carp::croak "Roles cannot support 'augment'";
- }
-
- sub requires {
- my $meta = Mouse::Meta::Role->initialize(scalar caller);
- $meta->throw_error("Must specify at least one method") unless @_;
- $meta->add_required_methods(@_);
- return;
- }
-
- sub excludes {
- not_supported;
- }
-
- sub init_meta{
- shift;
- my %args = @_;
-
- my $class = $args{for_class}
- or Carp::confess("Cannot call init_meta without specifying a for_class");
-
- my $metaclass = $args{metaclass} || 'Mouse::Meta::Role';
-
- my $meta = $metaclass->initialize($class);
-
- $meta->add_method(meta => sub{
- $metaclass->initialize(ref($_[0]) || $_[0]);
- });
-
- # make a role type for each Mouse role
- Mouse::Util::TypeConstraints::role_type($class)
- unless Mouse::Util::TypeConstraints::find_type_constraint($class);
-
- return $meta;
- }
-
- }
- BEGIN{ # lib/Mouse/Util/MetaRole.pm
- package Mouse::Util::MetaRole;
- use Mouse::Util; # enables strict and warnings
- use Scalar::Util ();
-
- sub apply_metaclass_roles {
- my %args = @_;
- _fixup_old_style_args(\%args);
-
- return apply_metaroles(%args);
- }
-
- sub apply_metaroles {
- my %args = @_;
-
- my $for = Scalar::Util::blessed($args{for})
- ? $args{for}
- : Mouse::Util::get_metaclass_by_name( $args{for} );
-
- if(!$for){
- Carp::confess("You must pass an initialized class, but '$args{for}' has no metaclass");
- }
-
- if ( Mouse::Util::is_a_metarole($for) ) {
- return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
- }
- else {
- return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
- }
- }
-
- sub _make_new_metaclass {
- my($for, $roles, $primary) = @_;
-
- return $for unless keys %{$roles};
-
- my $new_metaclass = exists($roles->{$primary})
- ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
- : ref $for;
-
- my %classes;
-
- for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
- my $metaclass;
- my $attr = $for->can($metaclass = ($key . '_metaclass'))
- || $for->can($metaclass = ($key . '_class'))
- || $for->throw_error("Unknown metaclass '$key'");
-
- $classes{ $metaclass }
- = _make_new_class( $for->$attr(), $roles->{$key} );
- }
-
- return $new_metaclass->reinitialize( $for, %classes );
- }
-
-
- sub _fixup_old_style_args {
- my $args = shift;
-
- return if $args->{class_metaroles} || $args->{roles_metaroles};
-
- $args->{for} = delete $args->{for_class}
- if exists $args->{for_class};
-
- my @old_keys = qw(
- attribute_metaclass_roles
- method_metaclass_roles
- wrapped_method_metaclass_roles
- instance_metaclass_roles
- constructor_class_roles
- destructor_class_roles
- error_class_roles
-
- application_to_class_class_roles
- application_to_role_class_roles
- application_to_instance_class_roles
- application_role_summation_class_roles
- );
-
- my $for = Scalar::Util::blessed($args->{for})
- ? $args->{for}
- : Mouse::Util::get_metaclass_by_name( $args->{for} );
-
- my $top_key;
- if( Mouse::Util::is_a_metaclass($for) ){
- $top_key = 'class_metaroles';
-
- $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
- if exists $args->{metaclass_roles};
- }
- else {
- $top_key = 'role_metaroles';
-
- $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
- if exists $args->{metaclass_roles};
- }
-
- for my $old_key (@old_keys) {
- my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
-
- $args->{$top_key}{$new_key} = delete $args->{$old_key}
- if exists $args->{$old_key};
- }
-
- return;
- }
-
-
- sub apply_base_class_roles {
- my %options = @_;
-
- my $for = $options{for_class};
-
- my $meta = Mouse::Util::class_of($for);
-
- my $new_base = _make_new_class(
- $for,
- $options{roles},
- [ $meta->superclasses() ],
- );
-
- $meta->superclasses($new_base)
- if $new_base ne $meta->name();
- return;
- }
-
- sub _make_new_class {
- my($existing_class, $roles, $superclasses) = @_;
-
- if(!$superclasses){
- return $existing_class if !$roles;
-
- my $meta = Mouse::Meta::Class->initialize($existing_class);
-
- return $existing_class
- if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
- }
-
- return Mouse::Meta::Class->create_anon_class(
- superclasses => $superclasses ? $superclasses : [$existing_class],
- roles => $roles,
- cache => 1,
- )->name();
- }
-
- }
- END_OF_TINY
- die $@ if $@;
- } # unless Mouse.pm is loaded
- package Mouse::Tiny;
-
- our $VERSION = '0.64';
-
- Mouse::Exporter->setup_import_methods(also => 'Mouse');
-
- 1;
-